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


    '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
    Let lReturn = SendMessageTimeout(lHwnd, WM_NULL, 0&, 0&, SMTO_ABORTIFHUNG And SMTO_BLOCK, lWaitTimeOut, lResult)
    If lReturn Then
        Let ApplicationResponding = True
        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


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

Related Posts Plugin for WordPress, Blogger...


diHITT - Notícias