|
なんとな～くできちゃった初期ディレクトリを指定できるバージョン。
さて、関数へ行く前にAPI宣言、定数などたくさんあるけどこれは適当に見てね。さて、この関数では初期ディレクトリを指定して、フォルダ選択ダイアログを表示するようにしているんだけど、このような場合、コールバック関数によりメッセージをフックしなければならない。初期ディレクトリを選択状態にして表示するには、フォルダ選択ダイアログが表示されるときに送られてくるメッセージ BFFM_INITIALIZED を拾い、 SendMessage 関数で初期選択ディレクトリを指定すればいい。
'SHBrowseForFolderで使用する構造体
Private Type BROWSEINFO
hwndOwner As Long '親Windowのハンドル
pidlRoot As Long 'ルートフォルダ種別
pszDisplayName As String '対象フォルダがExploreで表示される場合の文字
lpszTitle As String 'ダイアログに表示するメッセージ
ulFlags As Long 'オプション
lpfn As Long 'コールバック関数アドレス
lParam As Long 'コールバック関数用パラメータ
iImage As Long
End Type
'ブラウズフォルダダイアログを表示する
'ブラウズフォルダダイアログで指定されたフォルダのパスを取得する Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'メモリーをコピーする Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
'ルートフォルダ定数
Private Const CSIDL_DESKTOP = &H0 'デスクトップ
Private Const CSIDL_INTERNET = &H1 'インターネット
Private Const CSIDL_PROGRAMS = &H2 'プログラム
Private Const CSIDL_CONTROLS = &H3 'コントロールパネル
Private Const CSIDL_PRINTERS = &H4 'プリンター
Private Const CSIDL_PERSONAL = &H5 'パーソナル
Private Const CSIDL_FAVORITES = &H6 'ブックマーク
Private Const CSIDL_STARTUP = &H7 'スタートアップ
Private Const CSIDL_RECENT = &H8 '最近使ったファイル
Private Const CSIDL_SENDTO = &H9 '送る
Private Const CSIDL_BITBUCKET = &HA 'ごみ箱
Private Const CSIDL_STARTMENU = &HB 'スタートメニュー
Private Const CSIDL_DESKTOPDIRECTORY = &H10 'デスクトップショートカット
Private Const CSIDL_DRIVES = &H11 'マイコンピュータ
Private Const CSIDL_NETWORK = &H12 'ネットワークコンピュータ
Private Const CSIDL_NETHOOD = &H13 '(Windows\NetHood)
Private Const CSIDL_FONTS = &H14 'フォント
Private Const CSIDL_TEMPLATES = &H15 'Shell New
Private Const CSIDL_COMMON_STARTMENU = &H16 'スタートメニュー
Private Const CSIDL_COMMON_PROGRAMS = &H17 'プログラム
Private Const CSIDL_COMMON_STARTUP = &H18 'スタートアップ
Private Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19
Private Const CSIDL_APPDATA = &H1A '(Windows\Appdata)
Private Const CSIDL_PRINTHOOD = &H1B '(Windows\printhood)
'ulFlags用定数
Private Const BIF_DEFAULT = 0 '標準
Private Const BIF_RETURNONLYFSDIRS = 1 'ファイルシステムフォルダのみ選択可能
Private Const BIF_DONTGOBELOWDOMAIN = 2 'ネットワークフォルダーを表示しない
Private Const BIF_STATUSTEXT = 4 'ステータスエリアを表示
Private Const BIF_RETURNFSANCESTORS = 8 'ファイルシステムアンセスタのみ選択可能
Private Const BIF_BROWSEFORCOMPUTER = &H1000 'コンピュータのみ選択可能
Private Const BIF_BROWSEFORPRINTER = &H2000 'プリンタのみ選択可能
Private Const BIF_BROWSEINCLUDEFILES = &H4000 'フォルダ以外も表示
'SHBrowseForFolderのコールバック処理用の定数
Private Const BFFM_INITIALIZED = 1 '初期化時
Private Const BFFM_SELCHANGED = 2 '選択フォルダ変更時
'POSYMESSAG用
Private Const WM_USER = &H400
Private Const BFFM_SETSTATUSTEXTA = (WM_USER + 100) 'ステータスエリアに表示
Private Const BFFM_ENABLEOK = (WM_USER + 101) '選択可能
Private Const BFFM_SETSELECTIONA = (WM_USER + 102) 'フォルダ選択
Private Const BFFM_SETSELECTIONW = (WM_USER + 103) 'フォルダ選択 (UNICODE)
Private Const BFFM_SETSTATUSTEXTW = (WM_USER + 104) '??? UNICODE
以下は関数。
'---------------------------------------------------------------------------
' 関数名 ： GetFunctionAddress
' 機能 ： フック関数のアドレスを得る
' 引数 ： (in) lngAddressOfFunc … フック関数のアドレス
' 返り値 ： フック関数のアドレス
'---------------------------------------------------------------------------
Private Function GetFunctionAddress(ByVal lngAddressOfFunc As Long) As Long
GetFunctionAddress = lngAddressOfFunc
End Function
'---------------------------------------------------------------------------
' 関数名 ： BrowseCallbackProc
' 機能 ： フォルダ参照用コールバック
' 引数 ： (in) hwnd … ハンドル
' (in) uMsg … ウインドウメッセージ
' (in) lParam … 追加情報１
' (in) lpData … 追加情報２
' 返り値 ： なし
'---------------------------------------------------------------------------
Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, _
ByVal lpData As Long) As Long
Select Case uMsg
Case BFFM_INITIALIZED
Dim StrLenA As Long 'lpData より受け取った文字列の長さ(ANSI形式として)
Dim strWBuff() As Byte 'lpData より受け取った文字列データ格納用(Unicode形式として)
Dim strABuff As String 'lpData より受け取った文字列格納用(ANSI形式として)
'lpData にはUnicode文字列のポインタが送られてくる
'例えば、C:\Temp\Abc.txt であれば、内部ではでは
' C, ,:, ,\, ,T, ,e, ,m, ,p, ,\, ,A, ,b, ,c, ,., ,t, ,x, ,t, , …①
' 注)","は(カンマ)単に分かりやすいように区切りとして使用したものであり
' メモリー上に存在しているわけではない。
'となっている。したがって Unicode 文字としての文字列の長さを取得しなければ
'ならない。上の例で言うと lstrlenW(lpData)より15が得られる。ここまでは Unicode
'文字として扱えばいいが、これ以降はANSI文字として扱わねばならない。(CopyMemory
'関数はANSI文字として扱われているようなので…)実際はメモリーには①の様になって
'なっているので、ANSI文字として扱うと30バイトになる。これはlstrlenW(lpData) に
'２をかけた値に等しい。よって下のコードのようになる。
StrLenA = lstrlenW(lpData) * 2
'メモリー確保
ReDim Preserve strWBuff(StrLenA) As Byte
'メモリコピー
Call CopyMemory(strWBuff(0), ByVal lpData, StrLenA)
'バイト → 文字列変換
strABuff = strWBuff()
Call SendMessage(hWnd, BFFM_SETSELECTIONA, True, ByVal strABuff)
'Windows NT はこれだけで動くけどWindows95は駄目みたい
'Call SendMessage(hWnd, BFFM_SETSELECTIONW, True, ByVal lpData)
End Select
End Function
'---------------------------------------------------------------------------
' 関数名 ： ShowFolderDlg
' 機能 ： フォルダ参照ダイアログを表示する
' 引数 ： (in) frmhWnd … フォームのウインドウハンドル
' (in) IFolder … 初期フォルダ
' (in) dlgMessage … ダイアログで表示するメッセージ
' 返り値 ： 正常：選択されたフォルダのパス、エラー：空文字列
'---------------------------------------------------------------------------
Public Function ShowFolderDlg(ByVal frmhWnd As Long, _
Optional ByVal IFolder As String = "", _
Optional ByVal dlgMessage As String = "フォルダを選択してください") As String
Dim udtBROWSEINFO As BROWSEINFO 'BROWSEINFO構造体
Dim pidl As Long 'SHGetPathFromIDListの第１引数で指定する
Dim PathName As String * 256 '取得するフォルダ名
Dim tmpStrBuf As String
With udtBROWSEINFO
.hwndOwner = frmhWnd
.pidlRoot = CSIDL_DESKTOP 'ルートフォルダを設定
.lpszTitle = dlgMessage 'ダイアログで表示するメッセージを設定
.ulFlags = BIF_DEFAULT 'フォルダ表示/選択のフラグ
If IFolder <> "" Then
IFolder = IFolder & Chr$(0) & Chr$(0)
.lpfn = GetFunctionAddress(AddressOf BrowseCallbackProc) 'コールバック
tmpStrBuf = String$(LenB(IFolder), Chr$(0))
'確保した領域にポインタをコピーする
Call CopyMemory(ByVal tmpStrBuf, ByVal IFolder, LenB(IFolder))
.lParam = StrPtr(tmpStrBuf) '指定された初期フォルダへのポインタを指定
End If
End With
'ダイアログを呼び出す
pidl = SHBrowseForFolder(udtBROWSEINFO)
If pidl Then
If SHGetPathFromIDList(pidl, PathName) Then
'フォルダのフルパスを取得する
ShowFolderDlg = Left$(PathName, InStr(PathName, Chr$(0)) - 1)
End If
'割り当てられたメモリを開放
Call CoTaskMemFree(pidl)
End If
End Function
|