フォルダ参照ダイアログAPIをVBAに組み込んだときのESCキー押下

フォルダ参照ダイアログAPIをVBAに組み込み、フォルダ選択画面が表示されたとき、ダイアログ上の「OK」「キャンセル」以外に、キーボードの「ESC」キーを押下すると、VBAの「コードの実行を中止」ダイアログが表示されプログラムの実行が中断します。「ESC」キーを押下しても「キャンセル」と同等の処理で、「コードの実行を中止」ダイアログを表示しないようにできるでしょうか。お知恵をお貸しください。

No.2 ベストアンサー 回答者： KenKen_SP 回答日時： 2006/08/05 23:58

こんにちは、KenKen_SP です。

> eDi89Uy6さん...

？？このように表示されてるのですか^^;

> ダイアログ上の「OK」「キャンセル」以外に、キーボードの「ESC」キーを
> 押下すると、VBAの「コードの実行を中止」ダイアログが表示されプログラム
> の実行が中断します。

ご提示頂いたコードはキャンセル時に初期フォルダのパスをそのまま返すみたい
ですね。 つまり、ShowFolders 関数の呼び出し方次第なのですが、面倒な仕組
です。関数の仕様としてキャンセル時に初期フォルダを返すのって、余り宜しく
ない気がします。

また、CallBack を使っているのに、前回選択のフォルダを記憶してません...

これを修正するのはちょっと面倒なので、私が使っているものを Excel VBA
用に簡略化したものを提示します。ご参考下さい。

ユーザー定義関数 BrowseForFolder で、次の機能を関数化してあります。

　1.　フォルダ参照ダイアログを表示
　2.　前回の選択フォルダを記憶（Excel2000以上で機能します）
　3.　ユーザーが選択したフォルダの「￥マークで終わるパス」を返す（重要）

この関数は３つ引数を受付ますが、どれも省略可能です。それぞれの意味は、

第１引数：[strCaption] 省略可　ダイアログに表示する文字列
第２引数：[strRootPath] 省略可　初期表示のフォルダ（ルートパス）
　　　　　--＞初期値「デスクトップ（仮想）」です
第３引数：[blnFixRoot] 省略可　第２引数で指定した初期フォルダより上位
　　　　　のディレクトリーに移動可能にするかどうかを True / False で設定

　　　　　例）strPath = BrowseForFolder(,"D:\",True)
　　　　　　　--＞ D:\ が初期フォルダとして表示され、デスクトップまで OK
　　　　　例）strPath = BrowseForFolder(,"D:\",False)
　　　　　　　--＞ D:\ が初期フォルダとして表示され、それより上位は無理

となってます。

キャンセル時の戻り値は「 長さ0の文字列 ＝ vbNullString 」です。

【以下ソースコード】より下の部分を標準モジュールにコピペ
して下さい。ご質問の趣旨であるキャンセル時の処理ですが、ソース一番下に
Sub Sample() に書いておきました。

’【以下ソースコード】---------------------------------------------------

Option Explicit

' フォルダ参照ダイアログ

Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" ( _
　　lpBrowseInfo As BROWSEINFO _
) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _
　　ByVal pidl As Long, _
　　ByVal pszPath As String _
) As Long
Private Declare Function ILCreateFromPathA Lib "shell32.dll" Alias "#189" ( _
　　ByVal pszPath As String _
) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
　　 ByVal hwnd As Long, _
　　 ByVal wMsg As Long, _
　　 ByVal wParam As Long, _
　　 ByRef lParam As Any) As Long

' BROWSEINFO構造体
Private Type BROWSEINFO
　　hwndOwner　　　As Long　 ' オーナーウインドウのハンドル
　　pidlRoot　　　 As Long　 ' ルートフォルダ定数
　　pszDisplayName As String ' 選択フォルダ名
　　lpszTitle　　　As String ' ダイアログ表示メッセージ
　　ulFlags　　　　As Long　 ' オプション
　　lpfn　　　　　 As Long　 ' CallBack関数アドレス
　　lParam　　　　 As String ' CallBack関数パラメータ
　　iImage　　　　 As Long
End Type

Private Const CSIDL_DESKTOP = &H0
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const WM_USER = &H400
Private Const BFFM_SETSELECTIONA = (WM_USER + 102)
Private Const BFFM_INITIALIZED = 1

Private Const MAX_PATH = 260

' フォルダ参照ダイアログを開いて￥記号で終わるパスを返す
Public Function BrowseForFolder( _
　　Optional strCaption As String = "フォルダを指定して下さい", _
　　Optional strRootPath As String, _
　　Optional blnFixRoot As Boolean) As String

　　Dim udtBROWSEINFO As BROWSEINFO
　　Dim lngRet　　　　As Long
　　Dim strPath　　　 As String
　　Static strPrevDir As String

　　' BROWSEINFO構造体を用意
　　With udtBROWSEINFO
　　　　.hwndOwner = 0&
　　　　.pidlRoot = CSIDL_DESKTOP
　　　　If strRootPath <> vbNullString Then
　　　　　　If blnFixRoot Then
　　　　　　　　.pidlRoot = ILCreateFromPathA(strRootPath)
　　　　　　End If
　　　　　　If Len(strPrevDir) Then
　　　　　　　　strPrevDir = strRootPath
　　　　　　End If
　　　　End If
　　　　.lpszTitle = strCaption
　　　　.ulFlags = BIF_RETURNONLYFSDIRS
　　　　' Excel97 では AddressOf 演算子が使えないので
　　　　' 条件付きコンパイルする
　　　　#If VBA6 Then
　　　　　　.lpfn = GetPointer(AddressOf BrowseCallbackProc)
　　　　　　If Len(strPrevDir) Then
　　　　　　　　.lParam = strPrevDir
　　　　　　End If
　　　　#End If
　　End With
　　' フォルダの参照ダイアログ呼び出し
　　lngRet = SHBrowseForFolder(udtBROWSEINFO)
　　If lngRet > 0 Then
　　　　strPath = String$(MAX_PATH, vbNullChar)
　　　　Call SHGetPathFromIDList(lngRet, strPath)
　　　　Call CoTaskMemFree(lngRet)
　　　　strPath = Left$(strPath, InStr(strPath, vbNullChar) - 1)
　　　　' 前回参照フォルダ記憶
　　　　strPrevDir = strPath
　　　　' 戻り値（パスの終わりに￥を付与）
　　　　If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
　　　　BrowseForFolder = strPath
　　End If

End Function

' CallBack プロシージャのアドレスを返す
Private Function GetPointer(lngAddressOf As Long) As Long
　　GetPointer = lngAddressOf
End Function

' BrowseForFolder 関数 Callback プロシージャ
Private Function BrowseCallbackProc( _
　　ByVal hwnd As Long, ByVal uMsg As Long, _
　　ByVal lParam As Long, ByVal lpData As Long) As Long
　　If uMsg = BFFM_INITIALIZED Then
　　　　SendMessage hwnd, BFFM_SETSELECTIONA, 1, ByVal lpData
　　End If
End Function


’【以下使い方のサンプルコード】

Sub Sample()

　　Dim strPath As String
　　
　　strPath = BrowseForFolder()　　　’＜--基本的にはこれだけ
　　If strPath = vbNullString Then 　’＜--長さ0の文字列ならキャンセル
　　　　MsgBox "キャンセル"
　　　　Exit Sub　　　　　　　　　　 ’＜--キャンセル時は終了
　　End If
　　
　　’＜--以降の処理を書く--＞
　　’取り合えずパスを表示してみる
　　MsgBox strPath
　　' 選択されたフォルダにある Sample.xls を開いてみる
　　Workbooks.Open Filename:=strPath & "Sample.xls"

End Sub

この回答へのお礼

KenKen_SPさん
本当にご丁寧な回答を有難うございます。
大変参考になります。
また、何かありましたらよろしくお願いいたします。

お礼日時：2006/08/06 09:07

No.1 回答者： KenKen_SP 回答日時： 2006/08/05 22:38

レスなかなか付かないですね...現状のコードを補足してみて下さい。

API とあるので、SHBrowseForFolder を使っているのだと思いますが...

SHBrowseForFolder Win32API 関数を使っているなら ESC キー押下でも、
キャンセルボタンのクリックでも戻り値は 0 です。従って、それをトラップ
すれば良いわけですが...

SHBrowseForFolder を直接プロシージャに組み込んでいるのか、独自関数で
ラップしているのかご質問文からはわかりませんので、コードの提示がないと
これ以上の回答は無理です。

この回答への補足

eDi89Uy6さん　回答有難うございます
コードは以下の通りです
*********************************
Option Explicit

' フォルダ指定ダイアログを表示するAPI
Public Declare Function SHBrowseForFolder Lib "shell32.dll" (lpBrowseInfo As BROWSEINFO) As Long
' アイテム識別子のリストをシステムパスへ変換するAPI
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidl As Long, ByVal pszPath As String) As Long
' メッセージの送信API
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Type BROWSEINFO
hwndOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As String
iImage As Long
End Type

Public Const MAX_PATH As Long = 260

Public Const BIF_RETURNONLYFSDIRS As Long = &H1
Public Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Public Const BIF_STATUSTEXT As Long = &H4
Public Const BIF_RETURNFSANCESTORS As Long = &H8
Public Const BIF_EDITBOX As Long = &H10
Public Const BIF_VALIDATE As Long = &H20
Public Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Public Const BIF_BROWSEFORPRINTER As Long = &H2000
Public Const BIF_BROWSEINCLUDEFILES As Long = &H4000

Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SETSELECTIONA = (WM_USER + 102)

Public Function GetPointer(lngAddressOf As Long) As Long

'コールバック関数のアドレスを返す
GetPointer = lngAddressOf

End Function

Public Function BFFCallback(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long

'フォルダを指定のメッセージをダイアログへ送信
If uMsg = BFFM_INITIALIZED Then
Call SendMessage(hwnd, BFFM_SETSELECTIONA, True, ByVal lpData)
End If

End Function

'==================================================================================================
'　 概要　　　：　フォルダ選択ダイアログの表示
'　 引数　　　：　hwnd : 呼び出すフォームのハンドル
'　 　　　　　：　strTitle : フォルダ選択ダイアログのウィンドタイトル
'　 　　　　　：　strPath : 初期選択フォルダ名
'　 戻値　　　：　[OK]クリック時：指定されたフォルダ名　[キャンセル]クリック時：strPathと同じ内容
'==================================================================================================
Public Function ShowFolders(hwnd As Long, strTitle As String, strPath As String) As String

'BROWSEINFO構造体
Dim udtBrows As BROWSEINFO
Dim nRC As Long
Dim DataPath As String

'とりあえず指定されたフォルダを戻り値にセット
ShowFolders = strPath

'BROWSEINFO構造体設定
With udtBrows
.hwndOwner = hwnd
.pidlRoot = 0
.pszDisplayName = String(MAX_PATH, vbNullChar)
.lpszTitle = strTitle
.ulFlags = BIF_RETURNONLYFSDIRS
.lpfn = GetPointer(AddressOf BFFCallback)
.lParam = strPath & vbNullChar
.iImage = 0
End With

'フォルダ選択ダイアログ表示
nRC = SHBrowseForFolder(udtBrows)

'キャンセルされた場合は終了
If nRC = 0 Then
Exit Function
End If

'システムパスへ変換
DataPath = String(MAX_PATH, vbNullChar)
Call SHGetPathFromIDList(nRC, DataPath)

'NUll除去
DataPath = Left(DataPath, InStr(DataPath, vbNullChar) - 1)

'フォルダ名を戻り値にセット
ShowFolders = DataPath

End Function

補足日時：2006/08/05 23:03