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, lpdwResult As Long) As Long
Private Const SMTO_BLOCK = &H1
Private Const SMTO_ABORTIFHUNG = &H2
Private Const SC_CLOSE = &HF060&
Private Const WM_SYSCOMMAND = &H112
Private Const WM_NULL = &H0
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Const PROCESS_ALL_ACCESS = &H1F0FFF
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function TerminateProcess& Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long)
Private Declare Function GetWindowThreadProcessId& Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long)
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Public Enum HowToClose
hcForce
hcOneAtATime
hcAllAtOnce
End Enum
Public Enum WindowIdType
WindowClassName
WindowCaption
End Enum
Private hwnds() As Long
Private m_ClassOrCaption As String
Private m_Identify As WindowIdType
Public Sub CloseApplication(ByVal ClassOrCaption As String, Identify As WindowIdType, Optional CloseMethod As HowToClose = hcOneAtATime)
'By Nucleus & Tygur
'Allows you to close an application by caption or class name
'and optionally force closure
Dim pid&, hp&, lresult&, lcount&, i&
Dim bWndNonResponsive As Boolean
ReDim hwnds(0)
m_ClassOrCaption = ClassOrCaption
m_Identify = Identify
'// Get all handles of windows
EnumWindows AddressOf EnumWindowsProc, 0&
'// Now close each window
If hwnds(0) <> 0 Then
For lcount = 0 To UBound(hwnds)
If IsWindow(hwnds(lcount)) Then
bWndNonResponsive = (SendMessageTimeout(hwnds(lcount), WM_NULL, 0, 0, SMTO_ABORTIFHUNG, 10, 0) = 0)
If Not bWndNonResponsive Then
If CloseMethod = hcOneAtATime Then
' wait for user to close each app one at a time
SendMessage hwnds(lcount), WM_SYSCOMMAND, SC_CLOSE, 0
Else
' hcOneAtATimE or hcAllAtOnce therefore no need to wait for user
SendMessageTimeout hwnds(lcount), WM_SYSCOMMAND, SC_CLOSE, 0, 0, 500, 0
End If
End If
' Terminate happ if hanging or if want to force app to close
If IsWindow(hwnds(lcount)) And (CloseMethod = hcForce Or bWndNonResponsive) Then
GetWindowThreadProcessId hwnds(lcount), pid
hp = OpenProcess(PROCESS_ALL_ACCESS, 0&, pid)
TerminateProcess hp&, 0&
CloseHandle hp
End If
DoEvents
End If
Next lcount
End If
End Sub
Private Function EnumWindowsProc(ByVal hwnd As Long, ByVal lParam As Long) As Long
Dim Length&, sCaption$, Temp$, lpClassName$
If m_Identify = WindowClassName Then
'//Class name matching required
'Create a buffer
lpClassName = Space(256)
'retrieve the class name
GetClassName hwnd, lpClassName, 256
lpClassName = Left$(lpClassName, InStr(1, lpClassName, vbNullChar) - 1)
If LCase(lpClassName) = LCase(m_ClassOrCaption) Then
If hwnds(0) <> 0 Then ReDim Preserve hwnds(UBound(hwnds) + 1)
hwnds(UBound(hwnds)) = hwnd
End If
Else
'//Caption matching required
sCaption = Space(256)
GetWindowText hwnd, sCaption, 256
If Len(sCaption) Then
sCaption = Left$(sCaption, InStr(1, sCaption, vbNullChar) - 1)
If LCase(sCaption) Like LCase(m_ClassOrCaption) Then
If hwnds(0) <> 0 Then ReDim Preserve hwnds(UBound(hwnds) + 1)
hwnds(UBound(hwnds)) = hwnd
End If
End If
End If
EnumWindowsProc = True
End Function