waitforsingleobject 在 64 位 vba 上不起作用

Question

在 32 位机器上使用时，waitforsingleobject 会按预期工作并等待直到进程执行完成。我正在使用它来运行运行节点 js 命令的批处理文件。但是当我在 64 位机器上使用此代码时，批处理文件显示为已启动（命令窗口闪烁并消失），但它不会等待其执行完成。我正在使用 Office 365 中的 Excel。这是我在 VBA 中使用的代码 sn-p。此函数接收批处理文件名作为输入：

Public Sub ExecCmd(cmdline As String)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ReturnValue As Integer

' Initialize the STARTUPINFO structure:
start.cb = Len(start)

' Start the shelled application:
ReturnValue = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)

' Wait for the shelled application to finish:
Do
ReturnValue = WaitForSingleObject(proc.hProcess, 0)
DoEvents
Loop Until ReturnValue <> 258

ReturnValue = CloseHandle(proc.hProcess)
End Sub

还有，这里是使用 API 的声明。

Public Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal _
    hHandle As Long, ByVal dwMilliseconds As Long) As Long
    
    Public Declare PtrSafe Function CreateProcessA Lib "kernel32" (ByVal _
    lpApplicationName As Long, 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 Long, _
    lpStartupInfo As STARTUPINFO, lpProcessInformation As _
    PROCESS_INFORMATION) As Long
    
    Public Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal _
    hObject As Long) As Long

您能帮我解决这个问题吗？任何帮助都是非常可观的。

提前致谢。

Answer 1

应该如下所示。这应该适用于 32 位和 64 位。

Option Explicit

#If Win64 And VBA7 Then
    'some of these declaration get red in VBA6 (no worries)
    
    Private Type STARTUPINFO       ' x86, Win64
        cb              As Long    '   4      4
        padding1        As Long
        lpReserved      As String  '   4      8
        lpDesktop       As String  '   4      8
        lpTitle         As String  '   4      8
        dwX             As Long    '   4      4
        dwY             As Long    '   4      4
        dwXSize         As Long    '   4      4
        dwYSize         As Long    '   4      4
        dwXCountChars   As Long    '   4      4
        dwYCountChars   As Long    '   4      4
        dwFillAttribute As Long    '   4      4
        dwFlags         As Long    '   4      4
        wShowWindow     As Integer '   2      2
        cbReserved2     As Integer '   2      2
        padding2        As Long
        lpReserved2     As LongPtr '   4      8
        hStdInput       As LongPtr '   4      8
        hStdOutput      As LongPtr '   4      8
        hStdError       As LongPtr '   4      8
    End Type                   ' Sum: 68     96
    
    Private Type SECURITY_ATTRIBUTES
        nLength              As Long
        padding1             As Long
        lpSecurityDescriptor As LongPtr
        bInheritHandle       As Long
    End Type
    
    Private Type PROCESS_INFORMATION
        hProcess    As LongPtr
        hThread     As LongPtr
        dwProcessID As Long
        dwThreadID  As Long
    End Type
        
    Private Declare PtrSafe Function CreateProcess Lib "Kernel32" Alias "CreateProcessA" ( _
        ByVal lpAppName As String, ByVal lpCmdLine As String, lpProcAttr As Any, _
        lpThreadAttr As Any, ByVal lpInheritedHandle As Long, ByVal lpCreationFlags As Long, _
        ByVal lpEnv As Any, ByVal lpCurDir As String, lpStartupInfo As STARTUPINFO, _
        lpProcessInfo As PROCESS_INFORMATION) As LongPtr
        
    Private Declare PtrSafe Function WaitForSingleObject Lib "Kernel32" ( _
        ByVal hHandle As LongPtr, ByVal dwMilliseconds As Long) As Long
        
    Private Declare PtrSafe Function CloseHandle Lib "Kernel32" ( _
        ByVal hObject As LongPtr) As Long
        
#Else
    'some of these declaration get red in VBA7 (no worries)
    Private Declare Function CreateProcess Lib "Kernel32" Alias _
                                                "CreateProcessA" ( _
        ByVal lpAppName As Long, _
        ByVal lpCmdLine As String, _
        ByVal lpProcAttr As Long, _
        ByVal lpThreadAttr As Long, _
        ByVal lpInheritedHandle As Long, _
        ByVal lpCreationFlags As Long, _
        ByVal lpEnv As Long, _
        ByVal lpCurDir As Long, _
        lpStartupInfo As STARTUPINFO, _
        lpProcessInfo As PROCESS_INFORMATION _
        ) As Long
    
    Private Declare Function WaitForSingleObject Lib "Kernel32" ( _
        ByVal hHandle As Long, _
        ByVal dwMilliseconds As Long _
        ) As Long
        
    Private Declare Function CloseHandle Lib "Kernel32" ( _
        ByVal hObject As Long _
        ) As Long
        
    'Einige Datentypen erstellen
    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 SECURITY_ATTRIBUTES
        nLength              As Long
        lpSecurityDescriptor As Long
        bInheritHandle       As Long
    End Type
    
    Private Type PROCESS_INFORMATION
        hProcess    As Long
        hThread     As Long
        dwProcessID As Long
        dwThreadID  As Long
    End Type
#End If


Public Sub ExecCmd(ByVal cmdline As String)
    Dim proc As PROCESS_INFORMATION
    Dim start As STARTUPINFO
    
    #If Win64 And VBA7 Then
        Dim ReturnValueProcess As LongPtr
    #Else
        Dim ReturnValueProcess As Long
    #End If
    
    ' Initialize the STARTUPINFO structure:
    start.cb = Len(start)
    
    ' Start the shelled application:
    ReturnValueProcess = CreateProcessA(0&, cmdline, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
    
    ' Wait for the shelled application to finish:
    Dim ReturnValue As Long
    Do
        ReturnValue = WaitForSingleObject(proc.hProcess, 0)
        DoEvents
    Loop Until ReturnValue <> 258
    
    ReturnValue = CloseHandle(proc.hProcess)
End Sub

Answer 2

以下代码已达到我在此处发布此问题的目的。我想分享它以供将来参考。我从论坛帖子here得到了这个解决方案@

Option Explicit

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess _
    As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle _
    As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 

Private Sub ShellAndWait(ByVal program_name As String, _
                         Optional ByVal window_style As VbAppWinStyle = vbNormalFocus, _
                         Optional ByVal max_wait_seconds As Long = 0)
Dim lngProcessId As Long
Dim lngProcessHandle As Long
Dim datStartTime As Date
Const WAIT_TIMEOUT = &H102
Const SYNCHRONIZE As Long = &H100000
Const INFINITE As Long = &HFFFFFFFF

    ' Start the program.
    On Error GoTo ShellError
    lngProcessId = Shell(program_name, window_style)
    On Error GoTo 0
    
    DoEvents

    ' Wait for the program to finish.
    ' Get the process handle.
    lngProcessHandle = OpenProcess(SYNCHRONIZE, 0, lngProcessId)
    If lngProcessHandle <> 0 Then
        datStartTime = Now
        Do
          If WaitForSingleObject(lngProcessHandle, 250) <> WAIT_TIMEOUT Then
            Exit Do
          End If
          DoEvents
          If max_wait_seconds > 0 Then
            If DateDiff("s", datStartTime, Now) > max_wait_seconds Then Exit Do
          End If
        Loop
        CloseHandle lngProcessHandle
    End If
    Exit Sub
    
ShellError:
End Sub