2
\$\begingroup\$

I stumbled across this post on SO, and it had a link to some good code; however the code itself was a bit dated. Since the code has a "do not modify" clause I went back to the basics as noted by the urls in the comments and rebuilt it from the ground up using more or less the same style, except making it 64-bit friendly and exposing more of the API functionality.

Module Code: WinShellAPI

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

Edit: looking for feedback, especially compatibility issues. (Besides on non-Windows computers, of course)

Edit2 - Add a blurb: The original code linked in the opening paragraph extended VBA's built in toolset with a ShellWait() sub similar to the built in Shell() function except that it was a blocking system call so that the execution of the VBA code would stop and wait for ShellWait() to complete before it moves on to the next line of VBA code. By adding the blocking feature this allows you to write VBA that calls external programs and know that they've finished creating files, sending files, ... or what ever the external program needs to get done, before the VBA moves on and tries to use the results from that external program before they've been created. Their code I believe still works in 32-bit Access, however I'm running 64-bit so for that reason alone I needed a revision. In reviewing the code I came across a couple "bugs"; I'm not too sure if they were bugs at the time the original code was written but they are today so maybe the term "temporal-bugs" is better suited. Anyhow I fixed the two bugs(calling IsMissing(Long) and not calling CloseHandle(Proc.hThread)), and kept going from there. I added DefaultPath() so that you should be able to reuse the same code in Excel, Word, Outlook, ... and I think possibly the whole Office Suite(I would have preferred a constant if I could have gotten away with it). I moved the Shell part out to its own Shell64() so you can have a sub where blocking is optional yet still has all the additional exposed API as the strictly blocking ShellWait() version. Then because I run PowerShell stuff often enough I added PowerShell() with the same features to optionally run a command line string or a script file.

Looking at Shell64() and ShellWait()

  • CmdLine, WindowStyle: should be analogous with Shell(PathName,WindowStyle) and would work as a straight replacement except that Shell64() doesn't return the ThreadID(IMO I'm not too sure ThreadID is useful for anything, probably better off returning MyProc from Shell64()).
  • StartIn: is a nice API feature so that the first line of my batch file doesn't have to relocate itself and I've defaulted it in the VBA to be the same folder as the database/spreadsheet file the Module is saved in.
  • WaitForExit, WaitCycles, and WaitInterval: are all related to the blocking. WaitForExit turns blocking on/off, WaitCycles is the number of timeout cycles to wait(at least one) before moving on(indefinite if omitted), WaitInterval is the milliseconds used to set the timeout between cycles(does a DoEvents between cycles so that excel/access doesn't think the executable is frozen and to allow for user ctrl-break).
  • BasePriority: probably not used that often but allows you to change the task's execution priority on the CPU(realtime not recommended).
  • EnvConsts: also not likely to be used much since explicitly setting these clears out all the default ones. (open command prompt and use the set command to see your defaults)
  • AppName: this one is a bit harder to use, when present it needs to be a fully qualified path to the executable(I've also implemented %% expansion as seen on the command line in the VBA code so that should work too)

Looking at PowerShell()

  • ShellCmd, WindowStyle, StartIn: same as Shell64 except run under PowerShell instead of cmd(and definitely not cmd /c powershell).
  • Parameters: makes it easy to split off parameters passed to the command or script. Can be a single line as given on the command line, or a two dimensional variant array kinda like a dictionary{"parameter name", "parameter value"}.
  • WaitForExit, WaitCycles, WaitInterval same blocking functionality used in Shell64
  • BasePriority: same process elevation as Shell64
\$\endgroup\$
  • \$\begingroup\$ Would you add a little blurb about the purpose of this code and what it does, please? \$\endgroup\$ – Raystafarian Jun 10 '18 at 21:32
  • \$\begingroup\$ added Edit2 at the end, hope that helps. \$\endgroup\$ – Gregor y Jun 11 '18 at 21:11

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.