vba - VBA ShellWait API 32 和 64 位兼容性

Question

我有以下代码，我试图使其兼容 32 位和 64 位（Access 2010+）。

Option Compare Database
Option Explicit

'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Terry Kreft
Private Const STARTF_USESHOWWINDOW& = &H1
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&

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 LongPtr
    hStdOutput As LongPtr
    hStdError As LongPtr
End Type

Private Type PROCESS_INFORMATION
    hProcess As LongPtr
    hThread As LongPtr
    dwProcessID As Long
    dwThreadID As Long
End Type

'Added
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As LongPtr
    bInheritHandle As Long
End Type

Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal _
    hHandle As LongPtr, ByVal dwMilliseconds As Long) As Long




'Type not defined
Declare PtrSafe Function CreateProcessA Lib "kernel32" _
    (ByVal lpApplicationName As String, ByVal lpCommandLine As String, _
    lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, _
    ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, _
    ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, _
    lpProcessInformation As PROCESS_INFORMATION) As Long
    
' Original
'Private Declare 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
    
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal _
    hObject As LongPtr) As Long
    
Public Sub ShellWait(Pathname As String, Optional WindowStyle As Long)
    Dim proc As PROCESS_INFORMATION
    Dim start As STARTUPINFO
    Dim ret As Long
    ' Initialize the STARTUPINFO structure:
    With start
        .cb = Len(start)
        If Not IsMissing(WindowStyle) Then
            .dwFlags = STARTF_USESHOWWINDOW
            .wShowWindow = WindowStyle
        End If
    End With
    ' Start the shelled application:
    ret& = CreateProcessA(0&, Pathname, 0&, 0&, 1&, _
            NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc) 'TEST SECURITY_ATTRIBUTES Data Types
    ' Wait for the shelled application to finish:
    ret& = WaitForSingleObject(proc.hProcess, INFINITE)     ' TEST proc.hProcess is LongPtr
    ret& = CloseHandle(proc.hProcess)                   ' TEST proc.hProcess is LongPtr
End Sub


Public Function GetExecutableForFile(strFileName As String) As String
   Dim lngRetval As LongPtr
   Dim strExecName As String * 255
   lngRetval = FindExecutable(strFileName, vbNullString, strExecName)
   GetExecutableForFile = Left$(strExecName, InStr(strExecName, Chr$(0)) - 1)
End Function

Sub RunIt(strNewFullPath As String)
   Dim exeName As String

   exeName = GetExecutableForFile(strNewFullPath)
   Shell exeName & " " & Chr(34) & strNewFullPath & Chr(34), vbNormalFocus
End Sub

我已经通过在我认为应该存在的地方添加LongPtr来从这个站点对其进行修改。我还添加了原始代码中没有的SECURITY_ATTRIBUTES类型。

我在 ShellWait 子下的以下行中收到编译错误：

ret& = CreateProcessA(0&, Pathname, 0&, 0&, 1&, _
                NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)

错误出现在第三个参数上，并说："ByRef Argument Type Mismatched" 最初 SECURITY_ATTRIBUTES 是 Long 类型。

如果我改回 LongPtr 错误就消失了，但是当我尝试命令时它不起作用ShellWait "clac.exe"

逐行调试时我没有收到错误消息。什么都没发生。我首先在 64 位 Access 中进行测试。

标签： vbams-access

Answer 1

这里有几个问题需要解决。

首先，API 函数应该返回一个LongPtr. 您需要在函数声明语句中更改它。您还需要将ret变量更改为LongPtr.

其次，类型不匹配的原因是因为您的参数值0&不是 type SECURITY_ATTRIBUTES。您必须构建一个SECURITY_ATTRIBUTES类型并将其作为参数传递。

编辑：这是我在一个编译得很好的模块中的所有代码。只是想看看我是否可以帮助您理解为什么您仍然会收到编译器错误：

Option Explicit

'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Terry Kreft
Private Const STARTF_USESHOWWINDOW& = &H1
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&

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 LongPtr
    hStdOutput As LongPtr
    hStdError As LongPtr
End Type

Private Type PROCESS_INFORMATION
    hProcess As LongPtr
    hThread As LongPtr
    dwProcessID As Long
    dwThreadID As Long
End Type

'Added
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As LongPtr
    bInheritHandle As Long
End Type

Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal _
    hHandle As LongPtr, ByVal dwMilliseconds As Long) As Long




'Type not defined
Declare PtrSafe Function CreateProcessA Lib "kernel32" _
    (ByVal lpApplicationName As String, ByVal lpCommandLine As String, _
    lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, _
    ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, _
    ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, _
    lpProcessInformation As PROCESS_INFORMATION) As LongPtr
    
' Original
'Private Declare 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
    
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal _
    hObject As LongPtr) As Long
    
Public Sub ShellWait(Pathname As String, Optional WindowStyle As Long)
    Dim proc As PROCESS_INFORMATION
    Dim start As STARTUPINFO
    Dim ret As LongPtr
'Not used, but needed
    Dim si1 As SECURITY_ATTRIBUTES
    Dim si2 As SECURITY_ATTRIBUTES
    
    ' Initialize the STARTUPINFO structure:
    With start
        .cb = Len(start)
        If Not IsMissing(WindowStyle) Then
            .dwFlags = STARTF_USESHOWWINDOW
            .wShowWindow = WindowStyle
        End If
    End With
'Set the structure size
    si1.nLength = Len(si1)
    si2.nLength = Len(si2)
    ' Start the shelled application:
    ret = CreateProcessA(vbNullString, Pathname, si1, si2, False, _
            NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc) 'TEST SECURITY_ATTRIBUTES Data Types
    ' Wait for the shelled application to finish:
    ret = WaitForSingleObject(proc.hProcess, INFINITE)     ' TEST proc.hProcess is LongPtr
    ret = CloseHandle(proc.hProcess)                   ' TEST proc.hProcess is LongPtr
End Sub