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.
35,086 questions
0 comments No comments
{count} votes

2 answers

Sort by: Most helpful
  1. Dave Patrick 426.2K 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 No comments