VBA Tips - Verifica se uma aplicação está respondendo - Test if an application is responding and terminate application

Termo de Responsabilidade

Que tal verificar se uma aplicação está respondendo e em caso positivo finalizá-la?

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

    Let lReturn = GetWindowThreadProcessId(lHwnd, lPid)

    'Terminate the application

    Let lhwndProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, lPid)

    Let ApplicationTerminate = (TerminateProcess(lhwndProcess, 0&) <> 0)

    Let 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

    

    Let lReturn = SendMessageTimeout(lHwnd, WM_NULL, 0&, 0&, SMTO_ABORTIFHUNG And SMTO_BLOCK, lWaitTimeOut, lResult)

    

    If lReturn Then

        Let ApplicationResponding = True

    Else

        Let 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!

    Let 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

References:

Tags: VBA, Tips, application, responding, stop, close, terminate