基本上VB6启动了一个进程,但问题在于当它完成时如何关闭它。
shell "something.exe"
当外部程序显示“完成”消息框时,可以关闭它。但是,在显示消息框时,进程仍在任务管理器中运行。
如何检测消息框并终止程序?
shell "something.exe"
当外部程序显示“完成”消息框时,可以关闭它。但是,在显示消息框时,进程仍在任务管理器中运行。
如何检测消息框并终止程序?
试试这个
Option Explicit
'--- for CreateProcess
Private Const NORMAL_PRIORITY_CLASS As Long = &H20&
Private Const STARTF_USESHOWWINDOW As Long = 1
Private Const SW_HIDE As Long = 0
Private Const SW_SHOWDEFAULT As Long = 10
Private Const ERROR_ELEVATION_REQUIRED As Long = 740
'--- for WaitForXxx
Private Const INFINITE As Long = &HFFFFFFFF
'--- for ShellExecuteEx
Private Const SEE_MASK_NOCLOSEPROCESS As Long = &H40
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function ShellExecuteEx Lib "shell32.dll" Alias "ShellExecuteExA" (lpExecInfo As SHELLEXECUTEINFO) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hWnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As Long
nShow As Long
hInstApp As Long
' Optional fields
lpIDList As Long
lpClass As Long
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
Private Const MSG_ELEVATION_REQUIRED As String = "To run %1 as administrator please confirm next elevation of rights"
Public Function ShellWait( _
ByVal sFile As String, _
Optional sParams As String, _
Optional ByVal bStartHidden As Boolean, _
Optional oOwnerForm As VB.Form) As Long
Const FUNC_NAME As String = "ShellWait"
Dim sCommandLine As String
Dim uInfo As PROCESS_INFORMATION
Dim uStart As STARTUPINFO
Dim lExitCode As Long
Dim uShell As SHELLEXECUTEINFO
Dim sFileName As String
On Error GoTo EH
'--- win9x: fix spaces or not working on 9x
If InStr(sFile, " ") > 0 Then
sCommandLine = """" & sFile & """" & " " & sParams
Else
sCommandLine = sFile & " " & sParams
End If
uStart.cb = Len(uStart)
If bStartHidden Then
uStart.dwFlags = STARTF_USESHOWWINDOW
uStart.wShowWindow = SW_HIDE
End If
If CreateProcess(vbNullString, sCommandLine, 0, 0, 1, NORMAL_PRIORITY_CLASS, 0, vbNullString, uStart, uInfo) <> 0 Then
Call WaitForSingleObject(uInfo.hProcess, INFINITE)
If GetExitCodeProcess(uInfo.hProcess, lExitCode) <> 0 Then
ShellWait = lExitCode
End If
Call CloseHandle(uInfo.hThread)
Call CloseHandle(uInfo.hProcess)
Else
If Err.LastDllError = ERROR_ELEVATION_REQUIRED Then
If Not oOwnerForm Is Nothing Then
If InStrRev(sFile, "\") > 0 Then
sFileName = Mid(sFile, InStrRev(sFile, "\") + 1)
Else
sFileName = sFile
End If
MsgBox Replace(MSG_ELEVATION_REQUIRED, "%1", sFileName), vbExclamation
uShell.hWnd = oOwnerForm.hWnd
End If
With uShell
.cbSize = Len(uShell)
.fMask = SEE_MASK_NOCLOSEPROCESS
.lpVerb = "runas"
.lpFile = sFile
.lpParameters = sParams
.nShow = IIf(bStartHidden, SW_HIDE, SW_SHOWDEFAULT)
End With
If ShellExecuteEx(uShell) Then
Call WaitForSingleObject(uShell.hProcess, INFINITE)
If GetExitCodeProcess(uShell.hProcess, lExitCode) <> 0 Then
ShellWait = lExitCode
End If
Call CloseHandle(uShell.hProcess)
End If
End If
End If
Exit Function
EH:
Debug.Print FUNC_NAME; ": "; Error
Resume Next
End Function
Private Sub Command1_Click()
MsgBox "Exit code = " & ShellWait("cmd"), vbExclamation
End Sub
如果您知道程序的标题或类名,则可以使用FindWindow和PostMessage API调用来关闭它。
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_CLOSE = &H10
Dim hwnd As Long
hwnd = FindWindow(vbNullString, "WINDOW CAPTION HERE")
PostMessage hwnd, WM_CLOSE, CLng(0), CLng(0)