HOME > エクセルVBA > サンプル > ShellExecute

ShellExecute


【ファイル名】ShellExecute.xlsm
【バージョン】Ver 1.0.0.5
【作成日】2019年04月24日
【更新日】2021年04月27日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】ShellExecute.zip
【説明】Windows APIのShellExecuteのサンプルです。ファイルを実行するのにWindows APIを使う必要はありません。
メニュー

ファイル名は入力必須で、必要に応じてパラメーターとディレクトリを指定して「ShellExecute」ボタンを実行してください。
パラメーターなしのファイル名は、拡張子に関連付けたファイルで実行できます。

「ShellExecute」ボタン以外は、セルを選択してからボタンを実行してください。

下記のマイクロソフトのサイトを参考にしました。
【外部リンク】Windows > Apps > Win32 > API > The Windows Shell > Shellapi.h > ShellExecuteW function
【外部リンク】Windows > Apps > Win32 > API > Backup > Winbase.h > WinExec function

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="tab1" label="サンプル" keytip="S" insertBeforeMso="TabHome">
        <group id="group1" label="Windows APIのShellExecute" keytip="S">
          <box id="box1" boxStyle="vertical">
            <box id="box11" boxStyle="horizontal">
              <editBox id="FileEditBox" label="ファイル名:  " keytip="F" screentip="ファイル名"
                       supertip="ファイル名を入力してください。(入力必須)&#13;&#13;拡張子に関連付けたファイルで実行できます。"
                       sizeString="WWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMM" getText="getText" onChange="onChange" />
              <button id="SelectFileButton" label="参照..." keytip="B" supertip="ファイルを選択するダイアログを表示します。" onAction="onAction" />
            </box>
            <box id="box12" boxStyle="horizontal">
            <editBox id="ParametersEditBox" label="パラメーター:" keytip="P" screentip="パラメーター"
                     supertip="パラメーターを入力してください。" sizeString="WWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMM" getText="getText" onChange="onChange" />
              <button id="SelectParameterFileButton" label="参照..." keytip="B" supertip="パラメーターのファイルを選択するダイアログを表示します。" onAction="onAction" />
            </box>
            <box id="box13" boxStyle="horizontal">
              <editBox id="DirectoryEditBox" label="ディレクトリ: " keytip="D" screentip="ディレクトリ"
                       supertip="ディレクトリを入力してください。" sizeString="WWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMM" getText="getText" onChange="onChange" />
              <button id="SelectDirectoryButton" label="参照..." keytip="O" supertip="ディレクトリを選択するダイアログを表示します。" onAction="onAction" />
            </box>
          </box>
          <button id="ShellExecuteButton" label="ShellExecute" imageMso="MailMergeGoToNextRecord" keytip="S" size="large"
                  supertip="Windows APIのShellExecuteで入力したパラメーター、ディレクトリでファイルを実行します。" onAction="onAction" />
        </group>

        <group id="group2" label="アクティブ セルの実行" keytip="E">
          <box id="box2" boxStyle="vertical">
            <button id="ShellButton" label="Shell    " imageMso="MailMergeGoToNextRecord" keytip="H"
                    supertip="VBAのShellでアクティブ セルの実行ファイルを実行します。" onAction="onAction" />
            <button id="WinExecButton" label="WinExec" imageMso="MailMergeGoToNextRecord" keytip="W"
                    supertip="WinExecでアクティブ セルのコマンドを実行します。" onAction="onAction" />
            <button id="RunButton" label="Run      " imageMso="MailMergeGoToNextRecord" keytip="R"
                    supertip="WScript.ShellのRunでアクティブ セルのコマンドを実行します。" onAction="onAction" />
          </box>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

FunctionModule
Option Explicit

' ファイルのダイアログを表示してファイル名を取得します。キャンセルしたら空の文字列を返します。
Public Function GetFileDialog(Optional pInitialFileName As String = "", _
                              Optional pTitle As String = "ファイルの参照", _
                              Optional pButtonName As String = "参照(&B)", _
                              Optional pInitialView As Office.MsoFileDialogView = msoFileDialogViewList) As String

  GetFileDialog = ""
  
  With Application.FileDialog(msoFileDialogFilePicker)
    If pInitialFileName = "" Then
      .InitialFileName = CurDir()
    Else
      .InitialFileName = pInitialFileName
    End If
    .Title = pTitle
    .ButtonName = pButtonName
    .InitialView = pInitialView
    If .Show = 0 Then Exit Function ' [キャンセル]ボタン
    GetFileDialog = .SelectedItems(1)
  End With
End Function


' フォルダのダイアログを表示してフォルダ名を取得します。キャンセルしたら空の文字列を返します。
Public Function GetFolderDialog(Optional pInitialFileName As String = "", _
                              Optional pTitle As String = "ディレクトリの参照", _
                              Optional pButtonName As String = "参照(&B)", _
                              Optional pInitialView As Office.MsoFileDialogView = msoFileDialogViewList) As String

  GetFolderDialog = ""
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    If pInitialFileName = "" Then
      .InitialFileName = CurDir()
    Else
      .InitialFileName = pInitialFileName
    End If
    .Title = pTitle
    .ButtonName = pButtonName
    .InitialView = pInitialView
    If .Show = 0 Then Exit Function ' [キャンセル]ボタン
    GetFolderDialog = .SelectedItems(1)
  End With
End Function
このページの上

Module1
Option Explicit

' https://docs.microsoft.com/en-us/windows/win32/api/shellapi/nf-shellapi-shellexecutew
' ShellExecute
'   lpOperation: ファイルの拡張子に関連付けられたVerb(動詞)です。edit, explore, find, open, print, NULL(NULLは既定の動詞)など...
'   lpFile: 実行するファイル名
'   lpParameters: パラメーター(開くファイル名など)
'   lpDirectory: 作業フォルダーのフルパス。NULLはカレント。相対パスは不可。
'   nShowCmd: ウィンドウのサイズ、アクティブの状態
'   戻り値: 32以下はエラー

' https://docs.microsoft.com/en-us/windows/desktop/api/winbase/nf-winbase-winexec
' WinExec
'   lpCmdLine: コマンドライン
'   nCmdShow: ウィンドウのサイズ、アクティブの状態
'   戻り値: 32以下はエラー

#If Win64 Then
  Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteW" ( _
                                                                                 ByVal hwnd As LongPtr, _
                                                                                 ByVal lpOperation As LongPtr, _
                                                                                 ByVal lpFile As LongPtr, _
                                                                                 ByVal lpParameters As LongPtr, _
                                                                                 ByVal lpDirectory As LongPtr, _
                                                                                 ByVal nShowCmd As Long) As LongPtr
  ' 【注意】下記の引数の lpCmdLine はANSIにない文字コードが文字化けします。
  Declare PtrSafe Function WinExec Lib "kernel32" (ByVal lpCmdLine As String, ByVal nCmdShow As Long) As Long
#Else
  Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteW" ( _
                                                                          ByVal hwnd As Long, _
                                                                          ByVal lpOperation As Long, _
                                                                          ByVal lpFile As Long, _
                                                                          ByVal lpParameters As Long, _
                                                                          ByVal lpDirectory As Long, _
                                                                          ByVal nShowCmd As Long) As Long
  Declare Function WinExec Lib "kernel32" (ByVal lpCmdLine As String, ByVal nCmdShow As Long) As Long
#End If

Const MAX_PATH = 260

' ShellExecute のエラーコード
Const SE_ERR_FNF = 2&              ' 指定されたファイルが見つかりません。
Const SE_ERR_PNF = 3&              ' 指定されたパスが見つかりません。
Const SE_ERR_ACCESSDENIED = 5&     ' アクセスが拒否されました。
Const SE_ERR_OOM = 8&              ' このコマンドを処理するにはメモリ リソースが足りません。
Const SE_ERR_SHARE = 26&           ' ファイルは共有できません。
Const SE_ERR_ASSOCINCOMPLETE = 27& ' ファイルの関連付け情報が不完全です。
Const SE_ERR_DDETIMEOUT = 28&      ' DDEがタイム アウトです。
Const SE_ERR_DDEFAIL = 29&         ' DDEが失敗しました。
Const SE_ERR_DDEBUSY = 30&         ' DDEがビジーです。
Const SE_ERR_NOASSOC = 31&         ' ファイルの関連付けが利用できません。
Const SE_ERR_DLLNOTFOUND = 32&     ' DDLが見つかりません。

' ShowWindow() Commands
Const SW_HIDE = 0&            ' ウィンドウを表示しない
Const SW_SHOWNORMAL = 1&      ' ウィンドウが最小あるいは、最大の場合は元のサイズに戻し、アクティブ
Const SW_SHOWMINIMIZED = 2&   ' ウィンドウのサイズを最小にし、アクティブ
Const SW_SHOWMAXIMIZED = 3&   ' ウィンドウのサイズを最大にし、アクティブ
Const SW_SHOWNOACTIVATE = 4&  ' 直前の位置とサイズで表示し、アクティブ状態は変化しません。
Const SW_SHOWMINNOACTIVE = 7& ' ウィンドウのサイズを最小にする、アクティブ状態は変化しません。
Const SW_SHOWNA = 8&          ' ウィンドウのサイズを変更しない、アクティブ状態は変化しません。

Private rbRibbonUI As IRibbonUI ' リボン
Private rbFileText As String ' ファイル名のeditBoxの文字列
Private rbParametersText As String  ' パラメーターのeditBoxの文字列
Private rbDirectoryText As String  ' ディレクトリのeditBoxの文字列

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbFileText = ""
  rbParametersText = ""
  rbDirectoryText = ThisWorkbook.Path
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub onAction(control As IRibbonControl) ' ボタンの処理
  Dim Operation As String
  Dim FileName As String
  Dim Parameters As String
  Dim Directory As String
#If Win64 Then
  Dim ret As LongPtr
#Else
  Dim ret As Long
#End If
  
  Err.Clear ' エラーをクリアーする
  On Error GoTo ErrorHandle ' ◆ エラー処理ルーチンを有効にします。Windows API のエラーはトラップできません。
' --------------------------------------------------------------------------------------------------------------------------
  If control.ID <> "ShellExecuteButton" Then
    If ActiveCell Is Nothing Then Exit Sub
    If Len(ActiveCell.Value) < 1 Then
      MsgBox Prompt:="アクティブ セルにコマンドを入力してください。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Exit Sub
    End If
  End If
  
' コマンドにより処理
  Select Case control.ID ' 複数のボタンで共通して使うためIDにより分岐
    Case "ShellExecuteButton" ' ShellExecuteで実行する
      Operation = "open" + vbNullChar + vbNullChar
      FileName = rbFileText + vbNullChar + vbNullChar
      Parameters = rbParametersText + vbNullChar + vbNullChar
      Directory = rbDirectoryText + vbNullChar + vbNullChar
      
      If Len(rbFileText) < 1 Then
        MsgBox Prompt:="ファイル名を入力してください。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
        Exit Sub
      End If
      
      ret = ShellExecute(Application.hwnd, StrPtr(Operation), StrPtr(FileName), StrPtr(Parameters), StrPtr(Directory), SW_SHOWNA)
      ShowWindowsAPIError (ret)
    Case "SelectFileButton" ' ファイル名を選択する
      FileName = GetFileDialog(ThisWorkbook.Path)
      If FileName = "" Then Exit Sub
      rbFileText = FileName
      rbRibbonUI.InvalidateControl ("FileEditBox") ' DirectoryEditBoxの表示を更新する
    Case "SelectParameterFileButton" ' パラメーターのファイル名を選択する
      FileName = GetFileDialog(ThisWorkbook.Path)
      If FileName = "" Then Exit Sub
      rbParametersText = FileName
      rbRibbonUI.InvalidateControl ("ParametersEditBox") ' ParametersEditBoxの表示を更新する
    Case "SelectDirectoryButton" ' フォルダを選択する
      FileName = GetFolderDialog(ThisWorkbook.Path)
      If FileName = "" Then Exit Sub
      rbDirectoryText = FileName
      rbRibbonUI.InvalidateControl ("DirectoryEditBox") ' DirectoryEditBoxの表示を更新する
    Case "ShellButton" ' Shellで実行する
      Shell PathName:=CStr(ActiveCell.Value), WindowStyle:=vbNormalFocus
      ' VBAのShell関数のウィンドウ スタイル
      ' vbHide  ウィンドウを表示しない
      ' vbNormalFocus ウィンドウは元のサイズと位置、アクティブ
      ' vbMinimizedFocus  ウィンドウを最小化
      ' vbMaximizedFocus  ウィンドウを最大化
      ' vbNormalNoFocus ウィンドウは最新のサイズと位置、アクティブは変更しない
      ' vbMinimizedNoFocus  ウィンドウを最小化、アクティブは変更しない
    Case "WinExecButton" ' WinExecで実行する
      FileName = CStr(ActiveCell.Value) + vbNullChar + vbNullChar
      ret = WinExec(FileName, SW_SHOWNA)
      ShowWindowsAPIError (ret)
    Case "RunButton" ' Runで実行する
      Run ActiveCell.Value
    Case Else
      MsgBox Prompt:="コントロールID """ & control.ID & """ の処理がありません。" & vbNewLine & vbNewLine & "作者にご連絡ください。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
  End Select
  
  Exit Sub
' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
ErrorHandle:
  MsgBox Prompt:=Err.Number & ": " & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub

Sub getText(control As IRibbonControl, ByRef returnedVal) ' editBoxに文字列を代入する
  Select Case control.ID
    Case "FileEditBox"
      returnedVal = rbFileText
    Case "ParametersEditBox"
      returnedVal = rbParametersText
    Case "DirectoryEditBox"
      returnedVal = rbDirectoryText
  End Select
End Sub

Sub onChange(control As IRibbonControl, text As String) ' editBoxで[Enter]キーを押したか、他のコントロールに移動した場合のイベント
  Select Case control.ID
    Case "FileEditBox"
      rbFileText = text
    Case "ParametersEditBox"
      rbParametersText = text
    Case "DirectoryEditBox"
      rbDirectoryText = text
  End Select
End Sub

' Windows APIの処理でエラーを表示します。
#If Win64 Then
Sub ShowWindowsAPIError(DllError As LongPtr)
#Else
Sub ShowWindowsAPIError(DllError As Long)
#End If
  Select Case DllError ' Err.LastDllError
    Case 0 '
      MsgBox Prompt:="メモリまたはリソースが不足してます。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    Case SE_ERR_FNF
      MsgBox Prompt:="指定されたファイルが見つかりません。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    Case SE_ERR_PNF
      MsgBox Prompt:="指定されたパスが見つかりません。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    Case SE_ERR_ACCESSDENIED
      MsgBox Prompt:="アクセスが拒否されました。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    Case SE_ERR_OOM
      MsgBox Prompt:="このコマンドを処理するにはメモリ リソースが足りません。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    Case SE_ERR_SHARE
      MsgBox Prompt:="ファイルは共有できません。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    Case SE_ERR_ASSOCINCOMPLETE
      MsgBox Prompt:="ファイルの関連付け情報が不完全です。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    Case SE_ERR_DDETIMEOUT
      MsgBox Prompt:="DDEがタイム アウトです。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    Case SE_ERR_DDEFAIL
      MsgBox Prompt:="DDEが失敗しました。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    Case SE_ERR_DDEBUSY
      MsgBox Prompt:="DDEがビジーです。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    Case SE_ERR_NOASSOC
      MsgBox Prompt:="ファイルの関連付けが利用できません。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    Case SE_ERR_DLLNOTFOUND
      MsgBox Prompt:="", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    Case Else
      If DllError <= 32 Then ' 32以下はエラー
        MsgBox Prompt:="エラー番号:" & DllError & vbNewLine & vbNewLine & "Windows APIの処理でエラーが発生しました。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      End If
  End Select
End Sub

' Run メソッド
' https://docs.microsoft.com/ja-jp/previous-versions/windows/scripting/cc364421(v%3dmsdn.10)
' 指定したコマンドを実行します。
Sub Run(ByVal CommandLine As String, Optional ByVal WindowsStyle As Integer = 1, Optional ByVal WaitOnReturn As Boolean = False)
'  引数のWindowStyleの値は、ウィンドウのサイズと位置、アクティブ化
'  0: ウィンドウを非表示
'  1: ウィンドウをアクティブ、ウィンドウが最小化または最大化されている場合は、元のサイズと位置(既定)
'  2: ウィンドウを最小化、アクティブ
'  3: ウィンドウを最大化、アクティブ
'  4: ウィンドウを最新のサイズと位置で表示、非アクティブ
'  5: ウィンドウをアクティブ、現在のサイズと位置で表示
'  6: ウィンドウを最小化、非アクティブ
'  7: ウィンドウを最小化、非アクティブ
'  8: ウィンドウを現在の状態で表示し、非アクティブ
'  9: ウィンドウを非アクティブ、ウィンドウが最小化または最大化されている場合は、元のサイズと位置
' 10: アプリケーションを起動したプログラムの表示状態
  Dim FSO As IWshRuntimeLibrary.WshShell
  
  Set FSO = CreateObject("WScript.Shell")
  FSO.Run CommandLine
  Set FSO = Nothing
End Sub
IWshRuntimeLibrary.WshShell オブジェクトのRun メソッドは、下記のマイクロソフトのサイトを参考にしました。
【外部リンク】Run メソッド
このページの上