読者です 読者をやめる 読者になる 読者になる

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

VBA .NET

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

f:id:dechnostick:20120308021804p:image
エラーになる。

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

まとめ

ボタンを二つ作る
f:id:dechnostick:20120308022816p:image

左を 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