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

Question

基本上 vb6 会启动一个进程，但问题是在它完成后将其关闭。

shell "something.exe"

当外部程序显示 msgbox 说“完成”时，可以将其关闭。然而，当它显示 msgbox 时，该进程仍在 taskmgr 中运行。

如何检测msgbox并杀死程序？

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