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

FileRun


【ファイル名】FileRun.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年04月30日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】FileRun.zip
【説明】「ファイル名を指定して実行」を起動するサンプルです。

Windows APIでshell32.dllファイルの61番目の関数を使用して、「ファイル名を指定して実行」を起動します。
メニュー

プロンプトの左側のアイコンを変更しました。タイトルバーのアイコンは変更できません。
「ファイル名を指定して実行」

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="サンプル" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="ファイル名を指定して実行">
          <box id="Box1" boxStyle="horizontal">
            <menu id="Menu" label="メニュー" itemSize="normal" imageMso="HappyFace" size="normal" keytip="M">
              <button id="FileRunButton" label="ファイル名を指定して実行(&amp;F)" supertip="「ファイル名を指定して実行」を表示します。" onAction="onAction" />
              <button id="TitleButton" label="タイトルの変更(&amp;T)" supertip="タイトルを「コマンドを実行」に変更して表示します。" onAction="onAction" />
              <button id="PromptButton" label="プロンプトの変更(&amp;P)" supertip="プロンプトを「コマンドを入力してください」に変更して表示します。" onAction="onAction" />
              <button id="NOBROWSEButton" label="「参照」ボタンを隠す(&amp;B)" supertip="「参照」ボタンを隠します。" onAction="onAction" />
              <button id="NOMRUButton" label="空のテキストボックス(&amp;M)" supertip="最後に使用したコマンドを表示しません。" onAction="onAction" />
              <button id="NoLableButton" label="ラベルなし(&amp;L)" supertip="テキストボックスのラベルの「名前(O):」を表示しません。" onAction="onAction" />
              <button id="IconButton" label="アイコンを変更(&amp;I)" supertip="プロンプトの左側のアイコンを変更して表示します。&#13;&#13;タイトルバーのアイコンは変更できません。" onAction="onAction" />
            </menu>
          </box>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

Module1
Option Explicit

Private Const Run_NOBROWSE = 1  ' 「参照」ボタンを隠す。
Private Const Run_NOMRU = 2     ' 最後に使用したコマンドを表示しない。
Private Const Run_CalcDir = &H4 '
Private Const Run_NoLable = &H8 ' テキストボックスのラベルの「名前(O):」を表示しない。

#If Win64 Then
  ' 「ファイル名を指定して実行」を起動します。
  ' https://www.tek-tips.com/viewthread.cfm?qid=1065421
  ' http://dosugoff2008.narod.ru/faq/page02.html
  Private Declare PtrSafe Function SHRunDialog Lib "shell32.dll" Alias "#61" (ByVal hOwner As LongPtr, _
                                                                              ByVal hIcon As LongPtr, _
                                                                              ByVal szPath As LongPtr, _
                                                                              ByVal szTitle As LongPtr, _
                                                                              ByVal szPrompt As LongPtr, _
                                                                              ByVal uFlags As Long) As Long
                                                                              
' https://docs.microsoft.com/en-us/windows/win32/api/shellapi/nf-shellapi-extracticonw
  Private Declare PtrSafe Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconW" (ByVal hInst As LongPtr, ByVal lpszExeFileName As LongPtr, _
                                                                                       ByVal nIconIndex As Long) As LongPtr
  
#Else
  Private Declare Function SHRunDialog Lib "shell32.dll" Alias "#61" (ByVal hOwner As Long, ByVal hIcon As Long, ByVal szPath As Long, _
                                                                      ByVal szTitle As Long, ByVal szPrompt As Long, ByVal uFlags As Long) As Long
  Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconW" (ByVal hInst As Long, ByVal lpszExeFileName As Long, _
                                                                               ByVal nIconIndex As Long) As Long
#End If

Private rbRibbonUI As IRibbonUI   ' リボン

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

Sub onAction(control As IRibbonControl) ' 各メニューの処理
#If Win64 Then
  Dim hIcon As LongPtr
#Else
  Dim hIcon As Long
#End If

  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "FileRunButton"
      FileRun
    Case "TitleButton"
      FileRun "コマンドを実行"
    Case "PromptButton"
      FileRun "ファイル名を指定して実行", "コマンドを入力してください"
    Case "NOBROWSEButton" ' 「参照」ボタンを隠す。
      FileRun vbNullString, vbNullString, vbNullString, Run_NOBROWSE
    Case "NOMRUButton" ' 最後に使用したコマンドを表示しない。
      FileRun vbNullString, vbNullString, vbNullString, Run_NOMRU
    Case "NoLableButton" ' テキストボックスのラベルの「名前(O):」を表示しない。
      FileRun vbNullString, vbNullString, vbNullString, Run_NoLable
    Case "IconButton" ' プロンプトの左側のアイコンを変更して表示します。(タイトルバーのアイコンは変更できません。)
      hIcon = ExtractIcon(0, StrPtr("ImageRes.dll"), 311)
      FileRun vbNullString, vbNullString, vbNullString, Run_NOMRU, hIcon
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Exit Sub
  End Select
  
  Exit Sub
'-------------------------------------------------------------------------------------------------------------------------
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub

' 「ファイル名を指定して実行」を起動します。
#If Win64 Then
Sub FileRun(Optional Title As String = vbNullString, Optional Prompt As String = vbNullString, Optional Directory As String = vbNullString, Optional uFlags As Long = 0, Optional Icon As LongPtr = 0)
#Else
Sub FileRun(Optional Title As String = vbNullString, Optional Prompt As String = vbNullString, Optional Directory As String = vbNullString, Optional uFlags As Long = 0, Optional Icon As Long = 0)
#End If
   Call SHRunDialog(Application.hwnd, Icon, StrPtr(Directory), StrPtr(Title), StrPtr(Prompt), uFlags)
End Sub
このページの上

OtherModule
Option Explicit

' 「ファイル名を指定して実行」を起動します。
Sub Shell_FileRun()
' Shellの型を参照するには「ツール」の「参照設定」のメニューで、「Microsoft Shell Controls And Automation」をチェックし、「OK」ボタンを実行します。
' "C:\Windows\System32\shell32.dll"
  Dim Shell ' As Shell32.Shell
  
  Set Shell = CreateObject("Shell.Application")
  Shell.FileRun
  Set Shell = Nothing
End Sub

' 「ファイル名を指定して実行」を起動します。
Sub VBA_Interaction_Shell()
  Shell "RunDll32.exe shell32.dll,#61", vbNormalFocus
'  VBA.Interaction.Shell "RunDll32.exe shell32.dll,#61", vbNormalFocus
End Sub
このページの上