#037
右図のような「フォルダの参照」ダイアログを表示しフォルダを選択するには、"SHELL32.DLL"にあるWindowsAPIの「SHBrowseForFolder」関数と「SHGetPathFromIDList」関数を使用します。 まず標準モジュールに次のコードを記述します。ここで、"Type"や"Declare"で始まる部分はお決まりの記述ですのでそのまま使って下さい。"Type"や"Declare"の前に"Private"を付けることによってフォームのモジュールにも記述できます。また、GetBrowseFolderプロシージャはオリジナルなものですので、WinodwAPI名などを除いたプロシージャ名や変数名などは書き換えても構いません。
Type BROWSEINFO
hWndOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHBrowseForFolder Lib "SHELL32" (lpbi As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "SHELL32" (ByVal pIDL As Long, ByVal pszPath As String) As Long
Public Function GetBrowseFolder(strMsg As String) As String
'このプロシージャはフォルダの参照ダイアログを表示し選択されたフォルダ名を返します。
'もしダイアログで[キャンセル]ボタンが押された場合は長さゼロ("")の文字列を返します。
'引数 strMsg にはダイアログに表示する、"フォルダを指定して下さい"のような文字列を指定します。
Dim udtBrowseInfo As BROWSEINFO
Const cMaxPathLen = 256
Dim strBuffer As String * cMaxPathLen
Dim strPathBuffer As String * cMaxPathLen
Dim strRetPath As String
Dim lngRet As Long
With udtBrowseInfo
.hWndOwner = Application.hWndAccessApp
.pidlRoot = &H0
.pszDisplayName = strBuffer
.lpszTitle = strMsg & vbNullChar
.ulFlags = 1&
.lpfn = 0
.lParam = 0
.iImage = 0
End With
GetBrowseFolder = ""
lngRet = SHBrowseForFolder(udtBrowseInfo)
If lngRet <> 0 Then
If SHGetPathFromIDList(lngRet, strPathBuffer) <> 0 Then
GetBrowseFolder = Left(strPathBuffer, InStr(strPathBuffer, vbNullChar) - 1)
End If
End If
End Function
hWndOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHBrowseForFolder Lib "SHELL32" (lpbi As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "SHELL32" (ByVal pIDL As Long, ByVal pszPath As String) As Long
Public Function GetBrowseFolder(strMsg As String) As String
'このプロシージャはフォルダの参照ダイアログを表示し選択されたフォルダ名を返します。
'もしダイアログで[キャンセル]ボタンが押された場合は長さゼロ("")の文字列を返します。
'引数 strMsg にはダイアログに表示する、"フォルダを指定して下さい"のような文字列を指定します。
Dim udtBrowseInfo As BROWSEINFO
Const cMaxPathLen = 256
Dim strBuffer As String * cMaxPathLen
Dim strPathBuffer As String * cMaxPathLen
Dim strRetPath As String
Dim lngRet As Long
With udtBrowseInfo
.hWndOwner = Application.hWndAccessApp
.pidlRoot = &H0
.pszDisplayName = strBuffer
.lpszTitle = strMsg & vbNullChar
.ulFlags = 1&
.lpfn = 0
.lParam = 0
.iImage = 0
End With
GetBrowseFolder = ""
lngRet = SHBrowseForFolder(udtBrowseInfo)
If lngRet <> 0 Then
If SHGetPathFromIDList(lngRet, strPathBuffer) <> 0 Then
GetBrowseFolder = Left(strPathBuffer, InStr(strPathBuffer, vbNullChar) - 1)
End If
End If
End Function
次のコードは、上記のプロシージャを使って実際にフォルダ参照ダイアログを表示し、そこで選択されたフォルダ名を使って以降の処理を行う例です。ここでは、フォームの"cmdOutputText"という名前のコマンドボタンをクリックすることによって、テキストファイルの出力先となるフォルダを選択するためのダイアログを表示させています。
Private Sub cmdOutputText_Click()
Dim strFolder As String
'フォルダの参照ダイアログを表示
strFolder = GetBrowseFolder("テキストファイルを出力するフォルダを指定して下さい。")
If Len(strFolder) > 0 Then
'フォルダが選択されたとき
Open strFolder & "\OUTPUT.TXT" For Output As #1
・・・・・・以降テキストファイルの書き出し処理・・・・・・
Else
'キャンセルされたとき
Beep
End If
End Sub
Dim strFolder As String
'フォルダの参照ダイアログを表示
strFolder = GetBrowseFolder("テキストファイルを出力するフォルダを指定して下さい。")
If Len(strFolder) > 0 Then
'フォルダが選択されたとき
Open strFolder & "\OUTPUT.TXT" For Output As #1
・・・・・・以降テキストファイルの書き出し処理・・・・・・
Else
'キャンセルされたとき
Beep
End If
End Sub
