030103

タイトル	拡張子で関連付けされているアプリケーションのパスを取得する
対象言語	VB4.0, Access95以降
動作確認ＯＳ	Windows95,98,NT4.0
使用関数	FindExecutable
改築日	1999/04/21(1998/01/05)
Source Download

拡張子で関連付けされているアプリケーション
のパスを取得します。

1. フォームを作成しテキストボックス(Text1,Text2)とコマンドボタン（Command1）を貼り付けてください。

Option Explicit

Private Sub Command1_Click()

　　 Me!Text2 = Y_GetExecPath(Me!Text1)

End Sub

3.モジュールウインドウを作成し、下のソースを入力してください。

'拡張子に関連付けされているアプリケーションのフルパスを取得する。
Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, _
ByVal lpResult As String) As Long

Public Const MAX_PATH = 260

Public Const ERROR_FILE_NOT_FOUND = 2& 'ファイルが見つからない
Public Const ERROR_PATH_NOT_FOUND = 3& 'パス名が見つからない
Public Const ERROR_BAD_FORMAT = 11& 'Win32用EXEではないか EXE内にエラーがある

Public Function Y_GetExecPath(FilePath As String) As String
'*******************************************************************
'機能 : FindExecutable関数を呼び出し、ファイルの拡張子に関連付け
'　　　　されているアプリケーションのフルパスを取得する
'引数　: FilePath 　= 取得したいファイルのフルパス名
'*******************************************************************

　　 Dim strbuf As String
　　 Dim longret As Long
　　 Dim msg As String

'アプリケーション名のフルパスを取得する
　　 strbuf = String$(MAX_PATH, Chr$(0))
　　 longret = FindExecutable(FilePath, vbNullString, strbuf)
　　 If longret < 32 Then
　　　　 Select Case longret
　　　　　　 Case 0
　　　　　　　　 msg = "メモリ不足です。"
　　　　　　 Case ERROR_FILE_NOT_FOUND
　　　　　　　　 msg = "ファイルが見つかりません。"
　　　　　　 Case ERROR_PATH_NOT_FOUND
　　　　　　　　 msg = "ファイルのパスが見つかりません。"
　　　　　　 Case 31
　　　　　　　　 msg = "関連付けされていないファイルです。"
　　　　　　 Case Else
　　　　　　　　 msg = Str$(longret) + ":エラーファイルのパスを確認してください。 "
　　　　 End Select
　　　　 Call MsgBox(msg, 16)
　　　　 Y_GetExecPath = vbNullString
　　 Else
　　　　 Y_GetExecPath = EditBuf(strbuf)
　　 End If

End Function

Public Function EditBuf(Buf As String) As String
'***********************************************************
'機能 : 引数 Bufの文字列中の Nullコードを検索し、Nullコードを
' 除いた文字列を返す
'引数 : Buf = Nullコードを含む文字列
'戻り値: Nullコードを除いた文字列
'***********************************************************

　　 Dim i As Long
　　 Dim strbuf As String

　　 i = InStr(Buf, vbNullChar)
　　 If i <> 0 Then
　　　　 If Mid$(Buf, i + 1, 1) <> vbNullChar Then
　　　　　　 Mid$(Buf, i, 1) = " "
　　　　 End If
　　　　 strbuf = RTrim$(Buf)
　　　　 If Right$(strbuf, 1) = Chr$(34) Then
　　　　　　 EditBuf = RTrim$(Left$(strbuf, Len(strbuf) - 1))
　　　　 Else
　　　　　　 EditBuf = strbuf
　　　　 End If
　　 Else
　　　　 EditBuf = Buf
　　 End If

End Function