VB6：如何从VB6运行程序并在完成后关闭它？

Question

基本上VB6启动了一个进程，但问题在于当它完成时如何关闭它。

shell "something.exe"

当外部程序显示“完成”消息框时，可以关闭它。但是，在显示消息框时，进程仍在任务管理器中运行。

如何检测消息框并终止程序？

- bkbkbk

Answer 1

试试这个

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

- wqw

Answer 2

如果您知道程序的标题或类名，则可以使用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) 

- kor_