こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

投稿日時 - 2006-08-05 13:55:37

QNo.2321061

すぐに回答ほしいです

質問者が選んだベストアンサー

こんにちは、KenKen_SP です。

> eDi89Uy6さん...

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

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

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

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

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

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

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

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

第1引数:[strCaption] 省略可 ダイアログに表示する文字列
第2引数:[strRootPath] 省略可 初期表示のフォルダ(ルートパス)
     -->初期値「デスクトップ(仮想)」です
第3引数:[blnFixRoot] 省略可 第2引数で指定した初期フォルダより上位
     のディレクトリーに移動可能にするかどうかを 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

投稿日時 - 2006-08-05 23:58:44

お礼

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

投稿日時 - 2006-08-06 09:07:16

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.1

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

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

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

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

投稿日時 - 2006-08-05 22:38:52

補足

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:30

あなたにオススメの質問