Attribute VB_Name = "xSHBrowseForFolder関数"
' @(h) xSHBrowseForFolder関数.bas ver 1.0 ( '98.10.17 )
' @(s)
' [フォルダの選択]ダイアログの表示関数サンプルです｡
' 本モジュールはテスト用コードモジュールです。
'
' 補足).hwndOwner As Longにウインドウハンドルを指定することによって指定したハンドルより前に
' ダイアログを表示することができる。
'
Option Explicit
Private Type BROWSEINFO '' SHBrowseForFolderqで使用する構造体
hwndOwner As Long '' 親Windowのハンドル
pidlRoot As Long '' ルートフォルダ
pszDisplayName As Long
lpszTitle As String '' ダイアログに表示するメッセージ
ulFlags As Long '' オプション
lpfn As Long
lParam As Long
iImage As Long
End Type
'' ルートフォルダ定数
Private Const CSIDL_DESKTOP = &H0 '' デスクトップ
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_NETHOO = &H13 '' Network Neighborhood
Private Const CSIDL_FONTS = &H14 '' フォント
Private Const CSIDL_TEMPLATES = &H15 '' Shell New
'' ulFlags に指定する定数
Private Const BIF_RETURNONLYFSDIRS = &H1& '' フォルダのみ選択可能にします。
Private Const BIF_DONTGOBELOWDOMAIN = &H2& '' ネットワーク上のコンピューターを非表示にします。他のフラグと組み合わせます。
Private Const BIF_STATUSTEXT = &H4& '' ダイアログ上にステータス表示をします。
Private Const BIF_RETURNFSANCESTORS = &H8&
Private Const BIF_BROWSEFORCOMPUTER = &H1000& '' ネットワークコンピューター以下のコンピューターのみ選択可能にします。
Private Const BIF_BROWSEFORPRINTER = &H2000& '' プリンターのみ選択可能にします。
Private Const BIF_BROWSEINCLUDEFILES = &H4000& '' 全て選択可能にします。
'Private Const BIF_BROWSEFORCOMPUTER = 1 '' 特殊フォルダ(マイコンピュータ、コントロールパネル等)を選択させない
'' コールバック関数が受け取るメッセージ
Private Const BFFM_INITIALIZED As Long = &H1& '' ダイアログが初期化された
Private Const BFFM_SELCHANGED As Long = &H2& '' アイテムが選択された
'' コールバック関数からフォルダ参照ダイアログに送るメッセージ
Private Const BFFM_SETSTATUSTEXTA As Long = &H464& '' ステータステキストを設定する
Private Const BFFM_ENABLEOK As Long = &H465& '' OK ボタンの使用可否を設定する
Private Const BFFM_SETSELECTIONA As Long = &H466& '' アイテムを選択する
'
Private Declare Function SendMessageStr Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
'[フォルダの参照]ダイアログを呼び出す関数
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBROWSEINFO As BROWSEINFO) As Long
'SHBrowseForFolderで得られた値からフォルダのパスを取得する関数
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
'SHBrowseForFolderで得られた値のメモリを開放する関数
Private Declare Function SHFree Lib "shell32" Alias "#195" (ByVal pidl As Long) As Long
Sub xSHBrowseForFolderのテスト()
MsgBox xSHBrowseForFolder("テスト用にパスを指定してください。", "C:\Windows\Temp")
End Sub
' @(f)
'
' 機能 : [フォルダの参照]ダイアログを呼び出す関数
'
' 返り値 : 指定したフォルダのパス名
'
' 引き数 : xMsg - ダイアログに表示するメッセージ
'
' 機能説明 : [フォルダの参照]ダイアログを呼び出す関数
'
' 備考 : 特になし
'
Public Function xSHBrowseForFolder(ByVal xMsg As String, ByVal xDir As String) As String
Dim tbi As BROWSEINFO
Dim lngFoldPointer As Long
Dim strPathName As String
With tbi
.hwndOwner = 0& '' dummy
.pidlRoot = CSIDL_DESKTOP '' ルートフォルダを設定
.lpszTitle = xMsg
.ulFlags = BIF_RETURNONLYFSDIRS
'Excelでは使えない
' If (xDir <> "") Then
' .lpfn = GetFunctionAddress(AddressOf BrowseCallbackProc)
' .lParam = strParam & vbNullChar
' End If
End With
lngFoldPointer = SHBrowseForFolder(tbi) '' [フォルダの参照]ダイアログを呼び出す
strPathName = String$(256, 0&) '' 予めNull文字をセット
Call SHGetPathFromIDList(lngFoldPointer, strPathName) '' SHBrowseForFolderで得られた値からフォルダのパスを取得
Call SHFree(lngFoldPointer) '' 割り当てられたメモリを開放
xSHBrowseForFolder = strPathName
End Function
'*********************************************************************
'
' BrowseCallbackProc プライベート関数
'
' SHBrowseForFolder API のコールバック関数。
'
'*********************************************************************
Private Function BrowseCallbackProc( _
ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal lParam As Long, ByVal lpData As String) As Long
Select Case uMsg
Case BFFM_INITIALIZED ' ダイアログ初期化
'---------------------------------------------------------
' Note:
' BFFM_SETSELECTIONA を飛ばす際、wParam に 1& を
' 指定したならフォルダーのパス名を、0& を指定したなら
' フォルダーへの IDList へのポインターを渡します。
' 下記では、ANSI でもらったパス名を UNICODE に
' 変換してパス名を渡しています。
' ANSI への変換作業は VB が自動的に行ないます。
'---------------------------------------------------------
Call SendMessageStr(hwnd, BFFM_SETSELECTIONA, 1&, StrConv(lpData, vbUnicode))
Case BFFM_SELCHANGED ' アイテム選択
'---------------------------------------------------------
' Note:
' ここに、アイテムが選択された時の処理をいれます。
'---------------------------------------------------------
End Select
BrowseCallbackProc = 0&
End Function
'*********************************************************************
'
' GetFunctionAddress プライベート関数
'
' AddressOf 演算子で求めた関数アドレスをそのまま返します。
'
'*********************************************************************
Private Function GetFunctionAddress(ByVal lngAddressOfFunc As Long) As Long
GetFunctionAddress = lngAddressOfFunc
End Function