VBA で管理者権限に昇格する必要のある外部アプリを実行する

ShellExecuteEx で "runas" する。

こんな感じになる。

    Dim ei As SHELLEXECUTEINFO
    ei.cbSize = LenB(ei)
    ei.fMask = SEE_MASK_NOCLOSEPROCESS ' プロセスを終了させない
    ei.hwnd = GetActiveWindow() ' シートのハンドル
    ei.lpVerb = "runas"
    ei.lpFile = ActiveWorkbook.Path & "\ConsoleApplication1.exe"
    ei.lpParameters = "" ' コマンドライン引数(ある場合)
    ei.lpDirectory = ""
    ei.nShow = SW_HIDE ' コンソールを非表示にする
    
    ShellExecuteEx ei ' 実行

たとえばレジストリを読み取るようなプログラムを作って

Public Class Class1
    Public Shared Sub Main(ByVal args() As String)

        Try
            Dim regkey As Microsoft.Win32.RegistryKey = Microsoft.Win32.Registry.LocalMachine.OpenSubKey("Software\Microsoft\Windows NT\CurrentVersion", True)
            Dim stringValue As String = DirectCast(regkey.GetValue("ProductName"), String)
            regkey.Close()
            MsgBox("ProductName: " & stringValue)

        Catch ex As Exception
            MsgBox(ex.ToString())
            Environment.ExitCode = 1
            Return
        End Try

        Environment.ExitCode = 0
    End Sub
End Class

これを VBA から呼ぼうとして、

こんな風にやっても

    Dim r As Long
    Dim s: Set s = CreateObject("Wscript.Shell")
    r = s.Run(ActiveWorkbook.Path & "\ConsoleApplication1.exe", vbHide, True)
    Set s = Nothing

エラーになる。

だから ShellExecuteEx しなければならない。

まとめ

ボタンを二つ作る

左を CommandButton1、右を CommandButton2 として、Sheet1 に以下記述する。

Sheet1

' =========================================================
' UAC なし
' =========================================================
Private Sub CommandButton1_Click()
    
    Dim r As Long
    Dim s: Set s = CreateObject("Wscript.Shell")
    r = s.Run(ActiveWorkbook.Path & "\ConsoleApplication1.exe", vbHide, True)
    Set s = Nothing
    
    MsgBox ("ExitCode: " & r)
End Sub

' =========================================================
' UAC あり
' =========================================================
Private Sub CommandButton2_Click()
    
    Dim ei As SHELLEXECUTEINFO
    ei.cbSize = LenB(ei)
    ei.fMask = SEE_MASK_NOCLOSEPROCESS ' プロセスを終了させない
    ei.hwnd = GetActiveWindow() ' シートのハンドル
    ei.lpVerb = "runas"
    ei.lpFile = ActiveWorkbook.Path & "\ConsoleApplication1.exe"
    ei.lpParameters = "" ' コマンドライン引数(ある場合)
    ei.lpDirectory = ""
    ei.nShow = SW_HIDE ' コンソールを非表示にする
    
    ShellExecuteEx ei ' 実行
    
    Dim r As Long
    r = WaitForSingleObject(ei.hProcess, INFINITE) ' コマンド終了まで待機(タイムアウトなし)
    
    If r <> WAIT_OBJECT_0 Then
        MsgBox "異常終了"
        Exit Sub
    End If
    
    GetExitCodeProcess ei.hProcess, r ' ExitCode 取得
    
    CloseHandle ei.hProcess ' プロセス終了
    
    MsgBox ("ExitCode: " & r)
End Sub

「標準モジュール」

Public Const SW_HIDE = 0
Public Const SEE_MASK_NOCLOSEPROCESS = &H40
Public Const INFINITE = &HFFFF
Public Const STATUS_WAIT_0 = 0&
Public Const WAIT_OBJECT_0 = ((STATUS_WAIT_0) + 0&)

Type SHELLEXECUTEINFO
    cbSize As Long
    fMask As Long
    hwnd As Long
    lpVerb As String
    lpFile As String
    lpParameters As String
    lpDirectory As String
    nShow As Long
    hInstApp As Long
    lpIDList As Long
    lpClass As String
    hkeyClass As Long
    dwHotKey As Long
    hIcon As Long
    hProcess As Long
End Type

Declare Function ShellExecuteEx Lib "shell32.dll" Alias "ShellExecuteExA" (lpExecInfo As SHELLEXECUTEINFO) As Long
Declare Function GetActiveWindow Lib "user32.dll" () As Long
Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, ByRef lpdwExitCode As Long) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

ConsoleApplication1

Public Class Class1
    Public Shared Sub Main(ByVal args() As String)

        Try
            Dim regkey As Microsoft.Win32.RegistryKey = Microsoft.Win32.Registry.LocalMachine.OpenSubKey("Software\Microsoft\Windows NT\CurrentVersion", True)
            Dim stringValue As String = DirectCast(regkey.GetValue("ProductName"), String)
            regkey.Close()
            MsgBox("ProductName: " & stringValue)

        Catch ex As Exception
            MsgBox(ex.ToString())
            Environment.ExitCode = 1
            Return
        End Try

        Environment.ExitCode = 0
    End Sub
End Class