VBA ShellWait API 32 and 64 bit compatibility

Rick 41 Reputation points
2020-10-20T12:48:08.157+00:00

I have the following code that I tried to make compatible for 32 and 64 bit (Access 2010+).

Option Compare Database
Option Explicit

' https://stackoverflow.com/questions/64435163/vba-shellwait-api-32-and-64-bit-compatibility/64435711#64435711

'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

Declare PtrSafe Function CreateProcessA Lib "kernel32" _
    (ByVal lpApplicationName As String, ByVal lpCommandLine As String, _
    lpProcessAttributes As LongPtr, lpThreadAttributes As LongPtr, _
    ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, _
    ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, _
    lpProcessInformation As PROCESS_INFORMATION) As LongPtr

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

I already tinkered with it from this site by adding LongPtr where I believe it should of been. I also added SECURITY_ATTRIBUTES type that wasn't in the original code.

I am getting a compile error on the following line under the ShellWait sub:

ret = CreateProcessA(vbNullString, Pathname, si1, si2, False, _
                NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)

The error is on the third parameter (si1) and says: "ByRef Argument Type Mismatched".

Not Monitored
Not Monitored
Tag not monitored by Microsoft.
36,166 questions
0 comments

2 answers

Sort by: Most helpful
Most helpful Newest Oldest
  1. Dave Patrick 426.1K Reputation points MVP
    2020-10-20T12:58:23.567+00:00

    Access is not currently supported here on QnA. They're actively answering questions in dedicated forums here.
    https://answers.microsoft.com/en-us/msoffice/forum/msoffice_access
    https://social.msdn.microsoft.com/Forums/en-US/home?forum=accessdev

    --please don't forget to Accept as answer if the reply is helpful--

  2. Rick 41 Reputation points
    2023-03-08T10:30:53.0133333+00:00

    The following code worked in both 32 and 64 bit:

    https://codereview.stackexchange.com/questions/196131/ms-office-suite-vba-shellwait-and-powershell

    Option Explicit

'Syntatic sugar
Private Const QO As String = """"
Private Const SP As String = " "
Private Const NL As String = vbNewLine
Private Const NS As String = vbNullString 'reduces length, but also legibility

Private Const STARTF_USESHOWWINDOW As Long = &H1 'Windows constant see STARTUPINFO API linked below
'Private Const NORMAL_PRIORITY_CLASS = &H20&

'Wait time intervals are in milliseconds
Private Const ONE_MINUTE As Long = 1000& * 60&
Private Const FIVE_MINUTES As Long = ONE_MINUTE * 5&
Private Const INFINITE As Long = -1&  'Not recomended

Private Const WAIT_TIMEOUT As Long = 102&  'The time-out interval elapsed, and the object's state is nonsignaled.

Private Const CPP_NULL As Long = 0&
Private Const CPP_TRUE As Long = 1&
Private Const CPP_FALSE As Long = 0&

'This one is not really implemented, it can be combined with BasePriority using bitwise_or
'https://msdn.microsoft.com/en-us/library/windows/desktop/ms684863(v=vs.85).aspx
Public Enum ProcessCreationFlags
    CREATE_BREAKAWAY_FROM_JOB = &H1000000
    CREATE_DEFAULT_ERROR_MODE = &H4000000
    CREATE_NEW_CONSOLE = &H10&
    CREATE_NEW_PROCESS_GROUP = &H200&
    CREATE_NO_WINDOW = &H8000000
    CREATE_PROTECTED_PROCESS = &H40000
    CREATE_PRESERVE_CODE_AUTHZ_LEVEL = &H2000000
    CREATE_SECURE_PROCESS = &H400000
    CREATE_SEPARATE_WOW_VDM = &H800&
    CREATE_SHARED_WOW_VDM = &H1000&
    CREATE_SUSPENDED = &H4&
    CREATE_UNICODE_ENVIRONMENT = &H400&
    DEBUG_ONLY_THIS_PROCESS = &H2&
    DEBUG_PROCESS = &H1&
    DETACHED_PROCESS = &H8&
    EXTENDED_STARTUPINFO_PRESENT = &H80000
    INHERIT_PARENT_AFFINITY = &H10000
End Enum
'https://msdn.microsoft.com/en-us/library/windows/desktop/ms683211(v=vs.85).aspx
Public Enum ProcessPriorityClass
    REALTIME_PRIORITY_CLASS = &H100&
    HIGH_PRIORITY_CLASS = &H80&
    ABOVE_NORMAL_PRIORITY_CLASS = &H8000&
    NORMAL_PRIORITY_CLASS = &H20&
    BELOW_NORMAL_PRIORITY_CLASS = &H4000&
    IDLE_PRIORITY_CLASS = &H40&
End Enum

'Compatible with VbAppWinStyle, so I used that instead
'https://msdn.microsoft.com/en-us/library/windows/desktop/ms633548(v=vs.85).aspx
'Public Enum nCmdShow
'    SW_HIDE = 0           'Hides the window and activates another window.
'    SW_SHOWNORMAL         'Activates and displays a window. If the window is minimized or maximized, the system restores it to its original size and position. An application should specify this flag when displaying the window for the first time.
'    SW_SHOWMINIMIZED      'Activates the window and displays it as a minimized window.
'    SW_MAXIMIZE           'Maximizes the specified window.
'    SW_SHOWMAXIMIZED = 3  'Activates the window and displays it as a maximized window.
'    SW_SHOWNOACTIVATE     'Displays a window in its most recent size and position. This value is similar to SW_SHOWNORMAL, except that the window is not activated.
'    SW_SHOW               'Activates the window and displays it in its current size and position.
'    SW_MINIMIZE           'Minimizes the specified window and activates the next top-level window in the Z order.
'    SW_SHOWMINONACTIVE    'Displays the window as a minimized window. This value is similar to SW_SHOWMINIMIZED, except the window is not activated.
'    SW_SHOWNA             'Displays the window in its current size and position. This value is similar to SW_SHOW, except that the window is not activated.
'    SW_RESTORE            'Activates and displays the window. If the window is minimized or maximized, the system restores it to its original size and position. An application should specify this flag when restoring a minimized window.
'    SW_SHOWDEFAULT        'Sets the show state based on the SW_ value specified in the STARTUPINFO structure passed to the CreateProcess function by the program that started the application.
'    SW_FORCEMINIMIZE      'Minimizes a window, even if the thread that owns the window is not responding. This flag should only be used when minimizing windows from a different thread.
'End Enum

'https://msdn.microsoft.com/en-us/library/windows/desktop/aa379560(v=vs.85).aspx
'not implemented, i just used CPP_NULL for lpProcessAttributes and lpThreadAttributes
'Private Type SECURITY_ATTRIBUTES
'    dwLength As Long
'    lpSecurityDescriptor As LongPtr
'    bInheritHandle As Long
'End Type

'https://msdn.microsoft.com/en-us/library/windows/desktop/ms686331(v=vs.85).aspx
Private Type STARTUPINFO
    cb As Long 'The size of the structure in bytes
    lpReserved As String 'Reserved; must be CPP_NULL
    lpDesktop As String 'The name of the desktop, or the name of both the desktop and window station for this process.
    lpTitle As String 'For console processs, this is the title displayed in the title bar if a new console window is created.
    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 'Reserved for use by the C Run-time; must be zero.
    lpReserved2 As LongPtr 'Reserved for use by the C Run-time; must be NULL.
    hStdInput As LongPtr
    hStdOutput As LongPtr
    hStdError As LongPtr
End Type

'https://msdn.microsoft.com/en-us/library/windows/desktop/ms684873(v=vs.85).aspx
'If the function succeeds, be sure to call the CloseHandle function to close the hProcess and hThread handles when you are finished with them. Otherwise, when the child process exits, the system cannot clean up the process structures for the child process because the parent process still has open handles to the child process. However, the system will close these handles when the parent process terminates, so the structures related to the child process object would be cleaned up at this point.
Private Type PROCESS_INFORMATION
    hProcess As LongPtr 'A handle to the newly created process. The handle is used to specify the process in all functions that perform operations on the process object.
    hThread As LongPtr  'A handle to the primary thread of the newly created process. The handle is used to specify the thread in all functions that perform operations on the thread object.
    dwProcessID As Long 'A value that can be used to identify a process. The value is valid from the time the process is created until all handles to the process are closed and the process object is freed; at this point, the identifier may be reused.
    dwThreadID As Long  'A value that can be used to identify a thread. The value is valid from the time the thread is created until all handles to the thread are closed and the thread object is freed; at this point, the identifier may be reused.
End Type

'https://msdn.microsoft.com/en-us/library/windows/desktop/ms682425(v=vs.85).aspx
'lpApplicationName   'The function will not use the search path. This parameter must include the file name extension; no default extension is assumed.
'lpCommandLine       'If the file name does not contain a directory path, the system searches for the executable file
Private Declare PtrSafe Function WinAPI_CreateProcess Lib "kernel32" Alias "CreateProcessA" _
    (ByVal lpApplicationName As String, ByVal lpCommandLine As String, _
    ByVal lpProcessAttributes As LongPtr, ByVal lpThreadAttributes As LongPtr, _
    ByVal bInheritHandles As Long, ByVal dwCreationFlags As ProcessPriorityClass, _
    ByVal lpEnvironment As String, ByVal lpCurrentDirectory As String, _
    lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long

'https://msdn.microsoft.com/en-us/library/windows/desktop/ms687032(v=vs.85).aspx
Private Declare PtrSafe Function WinAPI_WaitForSingleObject Lib "kernel32" Alias "WaitForSingleObject" _
    (ByVal hHandle As LongPtr, ByVal dwMilliseconds As Long) As Long

'https://msdn.microsoft.com/en-us/library/windows/desktop/ms724211(v=vs.85).aspx
Private Declare PtrSafe Function WinAPI_CloseHandle Lib "kernel32" Alias "CloseHandle" (ByVal _
    hObject As LongPtr) As Long

'comment and uncomment as needed for each Offic App you're using
Private Function DefaultPath() As String
    DefaultPath = CurrentProject.Path 'MS-Access
'    DefaultPath = IIf(Application.ActiveWorkbook.Path = "", Application.Path, Application.ActiveWorkbook.Path) 'MS-Excel
'    DefaultPath = IIf(Application.ActiveDocument.Path = "", Application.Path, Application.ActiveDocument.Path) 'MS-Word
'    DefaultPath = Environ("temp")    'Windows Tmp
'    DefaultPath = Environ("appdata") 'Windows Application data
'    DefaultPath = "c:\your custom\path\" 'Manual entry
End Function

Private Function Quote(s As String, Optional q As String = QO) As String: Quote = q & s & q: End Function

Private Function WaitOnProc(Proc As PROCESS_INFORMATION, ByVal WaitCycles As Long, ByVal WaitInterval As Long) As Long
    If WaitCycles < 0 Then WaitCycles = -WaitCycles
    Do
        WaitOnProc = WinAPI_WaitForSingleObject(Proc.hProcess, FIVE_MINUTES)
        WaitCycles = WaitCycles - 1
        DoEvents
    Loop While WaitCycles > 0 And WaitOnProc = WAIT_TIMEOUT
End Function

'ToDo - find a better name than Shell64, since the current Shell() does work in 64-bit
Public Sub Shell64( _
 Optional ByVal CmdLine As String = NS, Optional WindowStyle As VbAppWinStyle = -1, Optional ByVal StartIn As String = NS, _
 Optional WaitForExit As Boolean = False, Optional WaitCycles, Optional WaitInterval As Long = FIVE_MINUTES, _
 Optional BasePriority As ProcessPriorityClass = NORMAL_PRIORITY_CLASS, Optional ByVal EnvConsts As String = NS, _
 Optional ByVal AppName As String = NS)

    If StrPtr(AppName) = 0 And StrPtr(CmdLine) = 0 Then Exit Sub

    If StrPtr(StartIn) = 0 Then StartIn = DefaultPath()

    'Expand %PathVariables%
    If StrPtr(AppName) <> 0 Then
        Dim at As Long, s As String
        at = InStr(AppName, "%") + 1
        Do While at > 1
            s = Mid(AppName, at, InStr(at, AppName, "%") - at)
            AppName = Replace(AppName, Quote(s, "%"), Environ(s))
            at = InStr(AppName, "%") + 1
        Loop
    End If

    ' Initialize STARTUPINFO
    Dim StartInfo As STARTUPINFO
    StartInfo.cb = Len(StartInfo)
    If WindowStyle <> -1 Then
        StartInfo.dwFlags = STARTF_USESHOWWINDOW
        StartInfo.wShowWindow = CInt(WindowStyle)
    End If

    ' Start the application
    Dim r As Long, MyProc As PROCESS_INFORMATION
    r = WinAPI_CreateProcess( _
            lpApplicationName:=AppName, _
            lpCommandLine:=CmdLine, _
            lpProcessAttributes:=CPP_NULL, _
            lpThreadAttributes:=CPP_NULL, _
            bInheritHandles:=CPP_TRUE, _
            dwCreationFlags:=BasePriority, _
            lpEnvironment:=EnvConsts, _
            lpCurrentDirectory:=StartIn, _
            lpStartupInfo:=StartInfo, _
            lpProcessInformation:=MyProc _
        )

    ' Wait for the application to finish
    If r <> CPP_FALSE Then
        If WaitForExit Then
            If IsMissing(WaitCycles) Then
                Do: r = WaitOnProc(MyProc, 0, WaitInterval): Loop Until r <> WAIT_TIMEOUT
            Else
                WaitOnProc MyProc, WaitCycles, WaitInterval
            End If
        End If
        'clean up
        r = WinAPI_CloseHandle(MyProc.hProcess)
        r = WinAPI_CloseHandle(MyProc.hThread)
    End If
End Sub

Private Sub ShellWait_test()
    'Tested on: Windows 7 64-Bit, MS-Access 2013 64-Bit, $PSVersionTable.PSVersion 5.1.14409.1012

    Dim MyEnvVars As String: MyEnvVars = _
        "ENV_VAR1=HI" & vbNullChar & _
        "ENV_VAR2=BYE" & vbNullChar

    ShellWait "cmd /k set", vbNormalFocus, "C:\Windows", 6, ONE_MINUTE, ABOVE_NORMAL_PRIORITY_CLASS, MyEnvVars
    ShellWait "-c ""& {date;pause}""", vbNormalFocus, , , , , , "%SystemRoot%\system32\WindowsPowerShell\v1.0\powershell.exe"
End Sub
'EnvConsts is a "null-terminated block of null-terminated strings", yes the last one has two null-terminations (vbNullChar & vbNullChar) for Char, and (vbNullChar & vbNullChar & vbNullChar & vbNullChar) for CharW
'EnvConsts example:
'   "HOMEDRIVE=H:" & vbNullChar & "HOMEPATH=\" & vbNullChar
Public Sub ShellWait( _
 Optional ByVal CmdLine As String = NS, Optional WindowStyle As VbAppWinStyle = -1, Optional ByVal StartIn As String = NS, _
 Optional WaitCycles, Optional WaitInterval As Long = FIVE_MINUTES, _
 Optional BasePriority As ProcessPriorityClass = NORMAL_PRIORITY_CLASS, Optional ByVal EnvConsts As String = NS, _
 Optional ByVal AppName As String = NS)
    If IsMissing(WaitCycles) Then
        Shell64 CmdLine, WindowStyle, StartIn, True, , WaitInterval, BasePriority, EnvConsts, AppName
    Else
        Shell64 CmdLine, WindowStyle, StartIn, True, WaitCycles, WaitInterval, BasePriority, EnvConsts, AppName
    End If
End Sub

Private Sub PowerShell_test()
    'Tested on: Windows 7 64-Bit, MS-Access 2013 64-Bit, $PSVersionTable.PSVersion 5.1.14409.1012
    PowerShell ShellCmd:="date;pause", WaitForExit:=True

    Dim StartInPath As String: StartInPath = "\\MyNetworkShare\Code\PowerShell"
    PowerShell ScriptFile:="hello.ps1", Parameters:="-wait", StartIn:=StartInPath, WindowStyle:=vbNormalFocus

    Dim Params As Variant: Params = Array( _
          Array("pName1", "pValue1") _
        , Array("pName2", "pValue2 with spaces") _
        , Array("switch1", "") _
        , Array("switch2", vbNullString) _
        , Array("wait", vbNullString) _
    )
    PowerShell ScriptFile:="hello.ps1", Parameters:=Params, StartIn:=StartInPath, WindowStyle:=vbNormalFocus

'    #hello.ps1
'    param([alias('Blocking')][switch]$Wait)
'    write-host "hello world"
'    if($wait){pause;}
End Sub
Public Sub PowerShell( _
 Optional ShellCmd As String = NS, Optional WindowStyle As VbAppWinStyle = -1, Optional StartIn As String = NS, _
 Optional Parameters, Optional ScriptFile As String = NS, _
 Optional WaitForExit As Boolean = False, Optional WaitCycles, Optional WaitInterval As Long = FIVE_MINUTES, _
 Optional BasePriority As ProcessPriorityClass = NORMAL_PRIORITY_CLASS)
    'implementation decision: require one or the other of either ShellCmd or ScriptFile, but not both
    If Not (StrPtr(ShellCmd) = 0 Xor StrPtr(ScriptFile) = 0) Then Exit Sub

    'The Command/Script's parameters are passed in as a commandline string or two dim {name,value} array
    Dim Params As String
    If Not IsMissing(Parameters) Then
        Select Case TypeName(Parameters)
          Case "String"
            'passed in as a string
            Params = SP & Trim(Parameters)
          Case "Variant()"
            If IsArray(Parameters) Then
                'passed in as a two dim array of nams,values
                Dim i As Long, j As Long, pVal As String
                For i = LBound(Parameters) To UBound(Parameters)
                    j = LBound(Parameters(i))
                    Params = Params & SP & "-" & Parameters(i)(j)
                    pVal = Parameters(i)(j + 1)
                    'note pVal:=vbNullString, gives same results because it's internally converted to "" for the comparison
                    If pVal <> "" Then Params = Params & SP & WrapToken(pVal) 'Parameter has a value
                Next i
            End If
            'Otherwise Variant but not String and not Array => ignore parameters
          Case Else 'ToDo - Not implemented, just skipped parameters
        End Select
    End If

    Dim PSpath As String, CmdLine As String
    If StrPtr(ScriptFile) <> 0 Then
        'Run a PowerShell Script
        PSpath = NS
        CmdLine = "powershell -ex unrestricted -f " & WrapToken(ScriptFile) & Params
    Else
        'Run a PowerShell Command
        PSpath = Environ("SystemRoot") & "\system32\WindowsPowerShell\v1.0\powershell.exe"
        CmdLine = "-c " & Quote("& {" & ShellCmd & Params & "}")
    End If

    ' Start PowerShell
    If IsMissing(WaitCycles) Then
        Shell64 CmdLine, WindowStyle, StartIn, WaitForExit, , WaitInterval, BasePriority, NS, PSpath
    Else
        Shell64 CmdLine, WindowStyle, StartIn, WaitForExit, WaitCycles, WaitInterval, BasePriority, NS, PSpath
    End If
End Sub

'used to wrap commandline tokens with quotes as needed
Private Function WrapToken(Token As String) As String
    Dim rChar As String: rChar = Chr(26) 'a character not likely to be in a command line string ''
    WrapToken = Token
    If InStr(WrapToken, SP) > 0 Or InStr(WrapToken, QO) > 0 Then
        'token contains a space or double quote character so it needs wrapped
                                          'For Example pVal = my string \\\"hello"
        WrapToken = Replace(WrapToken, "\\", rChar & rChar) ' my string ~~\"hello"
        WrapToken = Replace(WrapToken, "\" & QO, QO)        ' my string ~~"hello"
        WrapToken = Replace(WrapToken, QO, "\" & QO)        ' my string ~~\"hello\"
        WrapToken = Replace(WrapToken, rChar & rChar, "\\") ' my string \\\"hello\"
        WrapToken = Quote(WrapToken)                        ' "my string \\\"hello\""
    End If
End Function
    0 comments