Fremde Prozesse starten und abschießen

Wenn man ein fremdes Programm startet, hat man die Möglichkeit, zu warten, bis dieses beendet ist, um dann erst den Programmcode fortzusetzen. Dafür existiert auch ein Beispiel auf meiner Homepage. Startet man aber ein Programm asynchron und wartet nicht auf das Ende, hat man jegliche Kontrolle abgegeben.
Man kann sich nie sicher sein, dass das aufgerufene Programm auch wirklich ordnungsgemäß beendet wurde. Möglicherweise bleiben Prozessleichen zurück, die das System ausbremsen.Wenn man die ausführende Exe-Datei kennt und davon gehe ich aus, wenn man das fremde Programm selbst gestartet hat, hat man die Möglichkeit, diese nachträglich abzuschießen. Das ist zwar ein sehr rabiates Vorgehen, aber es funktioniert.

Beispielmappe (prozesskillen.zip 22 KB)

Option Explicit
Private Const MAX_PATH = 260
Private Const TH32CS_SNAPPROCESS As Long = 2
Private Const PROCESS_ALL_ACCESS = &H1F0FFF

Private Type PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID  As Long
    pcPriClassBase As Long
    dwFlags As Long
    szExeFile As String * MAX_PATH
End Type

Private Declare Function CreateToolhelp32Snapshot _
    Lib "kernel32" ( _
    ByVal dwFlags As Long, _
    ByVal th32ProcessID As Long _
    ) As Long

Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long _
    ) As Long

Private Declare Function Process32First Lib "kernel32" ( _
    ByVal hSnapshot As Long, _
    ByRef lppe As PROCESSENTRY32 _
    ) As Long

Private Declare Function Process32Next Lib "kernel32" ( _
    ByVal hSnapshot As Long, _
    ByRef lppe As PROCESSENTRY32 _
    ) As Long

Private Declare Function OpenProcess Lib "kernel32" ( _
    ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long _
    ) As Long

Private Declare Function TerminateProcess Lib "kernel32" ( _
    ByVal hProcess As Long, _
    ByVal uExitCode As Long _
    ) As Long

Sub test()
    'Teilname der .exe
    MsgBox KillDenProzess("notepad") & vbCrLf & _
        "Prozesse abgeschossen", vbOKOnly, "notepad"
End Sub

Public Function KillDenProzess( _
    Exename As String) As Long
Dim Snapshot As Long, Prozessinfo As PROCESSENTRY32
Dim Ret As Long, hProcess As Long, MyName As String
'Schnappschuss aller momentan laufenden Prozesse erzeugen
Snapshot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&)
With Prozessinfo
    .dwSize = Len(Prozessinfo)
    'Infos über ersten Prozess
    Ret = Process32First(Snapshot, Prozessinfo)
    Do While Ret
        MyName = StringVonAsciiZ(.szExeFile)
        If InStr(1, LCase(MyName), LCase(Exename)) Then
            'Richtige ausführbare Datei gefunden
            'Prozesshandle holen
            hProcess = OpenProcess(PROCESS_ALL_ACCESS, _
                0, .th32ProcessID)
            If hProcess Then
                'Prozess schonungslos abschießen
                TerminateProcess hProcess, 0&
                KillDenProzess = KillDenProzess + 1
                'Handle schließen
                CloseHandle hProcess
            End If
        End If
        'Infos über nächsten Prozess
        Ret = Process32Next(Snapshot, Prozessinfo)
    Loop
End With
'Handle schließen
CloseHandle Snapshot
End Function

Private Function StringVonAsciiZ(ASCIIZ As String)
'ASCIIZ String kürzen
If InStr(1, ASCIIZ, Chr(0)) > 0 Then
    StringVonAsciiZ = Left$(ASCIIZ, InStr(1, ASCIIZ, Chr(0)) - 1)
Else
    StringVonAsciiZ = ASCIIZ
End If
End Function

Im folgenden Beispiel wird ein fremdes Programm gestartet und man hat die Möglichkeit zu warten, bis dieses beendet ist. Ist es nach einer bestimmten Timeoutzeit noch nicht beendet, wird es abgeschossen

Beispielmappe (prozesskillen.zip 22 KB)

'Zum Testen in das Klassenmodul eines Tabellenblatts
Private Sub cmbStartWait_Click()
Dim Exename As String, Timout As Long
    Exename = Me.Range("A9")
    Timout = Me.Range("B19")
    If StartenUndWarten(Exename, 10) Then
        MsgBox Exename & " normal beendet"
    Else
        MsgBox Exename & " abgeschossen"
    End If
End Sub

Option Explicit
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STILL_ACTIVE = &H103
Private Const PROCESS_ALL_ACCESS = &H1F0FFF

Private Declare Function GetExitCodeProcess Lib _
    "kernel32" (ByVal hProcess As Long, _
    lpExitCode As Long) As Long

Declare Sub Sleep Lib "kernel32" (ByVal _
    dwMilliseconds As Long)
    
Private Declare Function TerminateProcess Lib "kernel32" ( _
    ByVal hProcess As Long, _
    ByVal uExitCode As Long _
    ) As Long

Private Declare Function OpenProcess Lib "kernel32" _
    (ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) As Long
    
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long _
    ) As Long

Sub test()
If StartenUndWarten("Notepad.exe", 10) Then
    MsgBox "Notepad normal beendet"
Else
    MsgBox "Notepad abgeschossen"
End If
End Sub

Public Function StartenUndWarten(Programmname As String, _
    Optional WartezeitSec As Long = 5) As Boolean
Dim hwndShell As Long, hwndProzess As Long
Dim lngLäuft As Long, Timeout As Date
hwndShell = Shell(Programmname, 1)
hwndProzess = OpenProcess(PROCESS_ALL_ACCESS, _
            0&, hwndShell)
Timeout = Now + TimeSerial(0, 0, WartezeitSec)
StartenUndWarten = True
Do
    GetExitCodeProcess hwndProzess, lngLäuft
    If Now > Timeout Then
        If lngLäuft = STILL_ACTIVE Then
            TerminateProcess hwndProzess, 0&
            StartenUndWarten = False
            Exit Do
        End If
    End If
    'ev.
    Sleep 100
Loop While lngLäuft = STILL_ACTIVE
CloseHandle hwndProzess
End Function