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

FindExecutable


【ファイル名】FindExecutable.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年05月13日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】FindExecutable.zip
【説明】Windows APIのFindExecutableW関数で、ファイルに関連付けられたファイル名を取得します。
メニュー

【外部リンク】Windows > Apps > Win32 > API > The Windows Shell > Shellapi.h >  FindExecutableW

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="拡張子に関連付けられたファイル名の取得">
          <button id="ShowFormButton" label="フォームを表示(&amp;S)" supertip="フォームを表示します。" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

UserForm1
Option Explicit
    
Private Const MAX_PATH = 260 ' パスの最大文字数
    
#If Win64 Then
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/shellapi/nf-shellapi-findexecutablew
  Private Declare PtrSafe Function FindExecutable Lib "shell32.dll" Alias "FindExecutableW" (ByVal lpFile As LongPtr, ByVal lpDirectory As LongPtr, ByVal lpResult As LongPtr) As LongPtr

#Else
  Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableW" (ByVal lpFile As Long, ByVal lpDirectory As Long, ByVal lpResult As Long) As Long
#End If

' 拡張子に関連付けられたファイル名を取得する
Private Sub CommandButton1_Click()
  Dim lpFile As String ' 入力したファイル名
  Dim lpDirectory As String ' ディレクトリ名(このサンプルは使わない)
  Dim lpResult As String ' 拡張子に関連付けられたファイル名(戻り)
#If Win64 Then
  Dim ret As LongPtr
#Else
  Dim ret As Long
#End If
  
  TextBox2.Text = ""
  
  If Len(TextBox1.Text) < 1 Then
    MsgBox Prompt:="ファイル名を入力してください。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    TextBox1.SetFocus
    Exit Sub
  End If
  
  lpFile = Replace(TextBox1.Text, """", "") ' 二重引用符を削除する
  
  If Len(lpFile) >= MAX_PATH Then ' ヌルを除く数(MAX_PATH -1)
    MsgBox Prompt:="入力した文字数が多すぎます。(259文字以下)", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    TextBox1.SetFocus
    Exit Sub
  End If
  
  lpFile = lpFile & String(MAX_PATH - Len(lpFile), vbNullChar)
  lpDirectory = String(MAX_PATH, vbNullChar)
  lpResult = String(MAX_PATH, vbNullChar)
  
#If Win64 Then ' 拡張子に関連付けられたファイル名を取得する。
  ret = FindExecutable(StrPtr(lpFile), StrPtr(lpDirectory), StrPtr(lpResult))
#Else
  ret = FindExecutable(StrPtr(lpFile), StrPtr(lpDirectory), StrPtr(lpResult))
#End If
  
  If ret > 32 Then
    TextBox2.Text = Left(lpResult, InStr(lpResult, vbNullChar) - 1)
  Else ' 32以下はエラー
    MsgBox Prompt:="拡張子に関連付けられたファイル名を取得できません。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    TextBox1.SetFocus
    Exit Sub
  End If

End Sub

Private Sub UserForm_Initialize()
  TextBox1.Text = ThisWorkbook.FullName
End Sub
このページの上

Module1
Option Explicit

Private rbRibbonUI As IRibbonUI   ' リボン

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

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "ShowFormButton"
      UserForm1.Show vbModal
    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
このページの上