'***************************************************************************************************
' 拡張子に関連付けられたプログラムの起動 Module1(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' [参照設定]
' ・Windows Script Host Object Model (※Button2_Clickのみ必要)
'***************************************************************************************************
' 変更日付 Rev 変更履歴内容---------------------------------------------------------------------->
' 04/11/13(1.0.0)新規作成
' 17/11/12(1.1.0)WScript処理等を含めて再作成
' 19/10/20(1.2.0)64ビットWindows対応
' 20/03/04(1.2.1)ダイアログを表示をmodFolderPicker1からmodFolderPicker2に変更
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle As String = "拡張子に関連付けられたプログラムの起動"
'---------------------------------------------------------------------------------------------------
#If VBA7 Then
' ■ShellExecute の宣言
Private Declare PtrSafe Function ShellExecute Lib "SHELL32.dll" _
Alias "ShellExecuteA" _
(ByVal hWnd As LongPtr, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
#Else
' ■ShellExecute の宣言
Private Declare Function ShellExecute Lib "SHELL32.dll" _
Alias "ShellExecuteA" _
(ByVal hWnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
#End If
'***************************************************************************************************
' ■■■ ワークシート上のボタンから起動される処理 ■■■
'***************************************************************************************************
'* 処理名 :Button1_Click
'* 機能 :拡張子に関連付けられたプログラムの起動(ShellExecute:API)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年10月20日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Sub Button1_Click()
'-----------------------------------------------------------------------------------------------
Dim strFilename As String ' ファイル名(フルパス)
#If VBA7 Then
Dim lngHwnd As LongPtr ' Excelのハンドル
#Else
Dim lngHwnd As Long ' Excelのハンドル
#End If
Dim lngRet As Long ' 処理結果
Dim strMSG As String ' メッセージWORK
'-----------------------------------------------------------------------------------------------
' 開くファイル名の取得
If Not FP_GetFilename(strFilename) Then Exit Sub
'-----------------------------------------------------------------------------------------------
' Excelのハンドル受け取り
lngHwnd = Application.hWnd
' 拡張子に関連付けられたプログラムの起動(API:ShellExecute)
lngRet = ShellExecute(lngHwnd, "Open", strFilename, vbNullString, vbNullString, 1)
'-----------------------------------------------------------------------------------------------
' 処理結果確認(戻り値が32以上は成功)
If lngRet < 32 Then
' 32未満はエラー⇒該当するメッセージをセット
Select Case lngRet
Case 2: strMSG = "ファイルが見つかりません。"
Case 3: strMSG = "パスが見つかりません。"
Case 5: strMSG = "アクセス不可です。"
Case 8: strMSG = "メモリオーバーフローしました。"
Case 30: strMSG = "ファイルが使用中です。"
Case 31: strMSG = "拡張子に関連付けられたプログラムが登録されていません。"
Case Else: strMSG = "その他エラーです。"
End Select
MsgBox strMSG, vbExclamation, g_cnsTitle
End If
End Sub
'***************************************************************************************************
'* 処理名 :Button2_Click
'* 機能 :拡張子に関連付けられたプログラムの起動(WScript:参照設定)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年11月12日
'* 作成者 :井上 治
'* 更新日 :2017年11月12日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Sub Button2_Click()
'-----------------------------------------------------------------------------------------------
Dim strFilename As String ' ファイル名(フルパス)
'-----------------------------------------------------------------------------------------------
' 開くファイル名の取得
If Not FP_GetFilename(strFilename) Then Exit Sub
'-----------------------------------------------------------------------------------------------
On Error Resume Next
With New WshShell
.Run strFilename
End With
' エラーか
If Err.Number <> 0 Then
MsgBox Err.Description, vbExclamation, g_cnsTitle
End If
On Error GoTo 0
End Sub
'***************************************************************************************************
'* 処理名 :Button3_Click
'* 機能 :拡張子に関連付けられたプログラムの起動(WScript:実行時バインド)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年11月12日
'* 作成者 :井上 治
'* 更新日 :2017年11月12日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Sub Button3_Click()
'-----------------------------------------------------------------------------------------------
Dim strFilename As String ' ファイル名(フルパス)
'-----------------------------------------------------------------------------------------------
' 開くファイル名の取得
If Not FP_GetFilename(strFilename) Then Exit Sub
'-----------------------------------------------------------------------------------------------
On Error Resume Next
With CreateObject("WScript.Shell")
.Run strFilename
End With
' エラーか
If Err.Number <> 0 Then
MsgBox Err.Description, vbExclamation, g_cnsTitle
End If
On Error GoTo 0
End Sub
'***************************************************************************************************
' ■■■ 共通サブ処理 ■■■
'***************************************************************************************************
'* 処理名 :FP_GetFilename
'* 機能 :ファイル名(フルパス)の取得
'---------------------------------------------------------------------------------------------------
'* 返り値 :処理成否(Boolean)
'* 引数 :Arg1 = ファイル名(String) ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年11月12日
'* 作成者 :井上 治
'* 更新日 :2020年03月04日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_GetFilename(ByRef strFilename As String) As Boolean
'-----------------------------------------------------------------------------------------------
' 「ファイルを開く」ダイアログを表示(modFolderPicker2)
strFilename = modFolderPicker2.OpenDialog(g_cnsTitle, , False, ThisWorkbook.Path, 3)
' ファイルが受け取れたかを返す
FP_GetFilename = strFilename <> ""
End Function
'------------------------------------------<< End of Source >>--------------------------------------
ワークシート上の各ボタンからの呼び出し処理が上から順に「