Sunday, June 17, 2012

Menutup Aplikasi Lain Berdasarkan Caption Menggunakan VB6

Mengenai cara menutup (close) aplikasi lain/luar berdasarkan caption yang ditentukan menggunakan Visual Basic 6.0 - Bagaimana kode menutup aplikasi lain menggunakan VB6 ini, bisa Anda simak kodenya di bawah ini:
Option Explicit

Private Const PROCESS_ALL_ACCESS = &H1F0FFF
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 GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag 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 GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal process As Long, lpExitCode As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal process As Long, ByVal uExitCode As Long) As Long

'Code that does the work
Public Function EndApplication(ByRef caption As String, ByRef frm As Form) As Boolean
Dim hwnd As Long
Dim appInstance As Long
Dim process As Long
Dim processID
Dim result As Boolean
Dim exitCode As Long
Dim returnValue As Long

On Error GoTo Error

If Trim(caption) = "" Then Exit Function
Do
hwnd = FindWindowByTitle(caption, frm)
If hwnd = 0 Then Exit Do
appInstance = GetWindowThreadProcessId(hwnd, processID)
'Get a handle for the process we're looking for
process = OpenProcess(PROCESS_ALL_ACCESS, 0&, processID)
If process <> 0 Then
'Next get our exit code (for use later)
GetExitCodeProcess process, exitCode
'Check for an exit code of 9 (zero)
If exitCode <> 0 Then
'It's not zero so close the window
returnValue = TerminateProcess(process, exitCode)
If result = False Then result = returnValue > 0
End If
End If
Loop
EndApplication = result
Error:
' MsgBox (Err.Number & ": " & Err.Description)
End Function

Private Function FindWindowByTitle(ByRef str As String, ByRef frm As Form) As Long
Dim handle As Long
Dim caption As String
Dim sTitle As String

handle = frm.hwnd
sTitle = LCase(str)
Do
DoEvents
If handle = 0 Then Exit Do
caption = LCase$(GetWindowCaption(handle))

If InStr(caption, sTitle) Then
FindWindowByTitle = handle
Exit Do
Else
FindWindowByTitle = 0
End If
handle = GetNextWindow(handle, 2)
Loop
End Function

Private Function GetWindowCaption(ByRef handle As Long) As String
Dim str As String
Dim length As Long

length& = GetWindowTextLength(handle)
str = String(length, 0)
Call GetWindowText(handle, str, length + 1)
GetWindowCaption = str
End Function
Contoh penggunaan kode di atas:
Private Sub Command1_Click()
Shell "Regedit", vbNormalFocus 'membuka regedit.exe
End Sub

Private Sub Command2_Click()
EndApplication "Registry Editor", Me 'menutup regedit.exe yang memiliki caption 'Registry Editor'
End Sub