Visual Basic > Applications-VBA

Test if an application is responding and terminate application

Test if an application is responding and terminate application

Below are some useful routines to test if an application has stopped responding and to terminate an application. A demonstration routine can be found at the bottom of the post.

Option Explicit
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, pdwResult As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId 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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long 

'Purpose     :  Terminates an application by finding the process ID of a windows handle.
'Inputs      :  lHwnd               The application window handle
'Outputs     :  Returns True if succeeds
'Notes       :  If you know the applications process ID then you need only call the last three lines of this routine.


Function ApplicationTerminate(lHwnd As Long) As Boolean
    Dim lPid As Long, lReturn As Long, lhwndProcess As Long
    Const PROCESS_ALL_ACCESS = &H1F0FFF
    'Get the PID (process ID) from the application handle
    lReturn = GetWindowThreadProcessId(lHwnd, lPid)
    'Terminate the application
    lhwndProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, lPid)
    ApplicationTerminate = (TerminateProcess(lhwndProcess, 0&) <> 0)
    lReturn = CloseHandle(lhwndProcess) 
End Function


'Purpose     :  Tests the status of an application
'Inputs      :  lHwnd               The application window handle
'               [lWaitTimeOut]      The time in ms to wait for the application to respond
'Outputs     :  Returns True if application is responding, else returns
'               false if the application is not responding
'Notes       :  SMTO_ABORTIFHUNG Returns without waiting for the time-out period to elapse if the receiving
'               process appears to be in a "hung" state.
'               SMTO_BLOCK Prevents the calling thread from processing any other requests until the function returns.


Function ApplicationResponding(lHwnd As Long, Optional lWaitTimeOut As Long = 2000) As Boolean
    Dim lResult As Long
    Dim lReturn As Long
    Const SMTO_BLOCK = &H1, SMTO_ABORTIFHUNG = &H2, WM_NULL = &H0
    
    lReturn = SendMessageTimeout(lHwnd, WM_NULL, 0&, 0&, SMTO_ABORTIFHUNG And SMTO_BLOCK, lWaitTimeOut, lResult)
    
    If lReturn Then
        ApplicationResponding = True
    Else
        ApplicationResponding = False
    End If
End Function

'Demonstration routine
Sub Test()
    Dim lHwnd As Long
    'Find an instance of internet explorer
    'I used IE to test it as it only takes about 2 mins before it hangs!
    lHwnd = FindWindow("IEFrame", vbNullString)
    If lHwnd Then
        If ApplicationResponding(lHwnd) = False Then
            'Application is not responding
            If ApplicationTerminate(lHwnd) = True Then
                MsgBox "Successfully terminated application"
            End If
        End If
    End If
End Sub