| |
んでもって本体
'*******************************************************************************************
'[BrowseCallbackProc] コールバックされたメッセージによってメッセージを送る
' (コールバック関数)
'
'引数 hwnd [SHBrowseForFolder]ウィンドウハンドル(Long)
' uMsg 受信メッセージコード(Long)
' lParam パラメータ値(Long)
' lpData BROWSEINFO構造体のlParamメンバに設定された値(Long)
'*******************************************************************************************
Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As BFFM_CallBackMsgCode, _
ByVal lParam As Long, ByVal lpData As Long) As Long
'メッセージコードが初期化終了の場合
Select Case uMsg
Case BFFM_INITIALIZED
'初期フォルダを設定するメッセージ送信
Call SendMessage(hwnd, BFFM_SETSELECTIONA, 1, ByVal mstrDefaultPath)
Case Else
End Select
End Function
'*******************************************************************************************
'[FARPROC] AddressOf演算子の戻り値を戻す関数
'
' ※ AddressOf演算子の値を変数に直接代入することができないので、
' ダミーとして標準モジュール上に[FARPROC]関数を作成する。
'
'戻り値 対象モジュールのアドレス
'
'引数 pfn 対象モジュールのアドレス(Long)
'*******************************************************************************************
Private Function FARPROC(pfn As Long) As Long
FARPROC = pfn
End Function
'*******************************************************************************************
'[F_strSHBrowseForFolder] BrowseForFolderを表示し、選択されたパス名を返す
'
'戻り値 選択フォルダパス名(String)
'
'引数 strDefaultPath 初期表示フォルダ(String)
' strPrompt 表示文字列(String)
' lngFlag [BROWSEINFO]構造体のulFlag(Long)
' lngpidlRoot [BROWSEINFO]構造体のpidlRoot(Long)
' hOwner 親ウィンドウハンドル(Long)
'*******************************************************************************************
Public Function F_strSHBrowseForFolder( _
Optional ByVal strDefaultPath As String = "", _
Optional ByVal strPrompt As String = "フォルダを選択してください。", _
Optional ByVal lngFlag As BrowseInfoFlags = BIF_RETURNONLYFSDIRS, _
Optional ByVal lngpidlRoot As gEnumCSIDL = CSIDL_DESKTOP, _
Optional ByVal hOwner As Long = -1) As String
Dim udtBrowseInfo As tagBROWSEINFO '[BROWSEINFO]構造体
Dim lngFolderPID As Long '選択フォルダPID
Dim strFolderPath As String * MAX_PATH '選択フォルダパス名(初期値:vbNullChar * MAX_PATH )
'初期フォルダ指定
mstrDefaultPath = IIf(strDefaultPath = "", CurDir, strDefaultPath)
'[BROWSEINFO]構造体初期化
With udtBrowseInfo
'親ウィンドウ設定
.hOwner = IIf(hOwner = -1, FindWindow("XLMAIN", vbNullString), hOwner)
.pidlRoot = lngpidlRoot 'ルートフォルダ指定
.lpszTitle = strPrompt '表示文字列指定
.ulFlags = lngFlag 'オプションフラグ指定
.lpfn = FARPROC(AddressOf BrowseCallbackProc) 'コールバック関数のアドレス代入
End With
'フォルダ選択ダイアログの表示
lngFolderPID = SHBrowseForFolder(udtBrowseInfo)
'選択フォルダのPIDが取得できた場合
If lngFolderPID <> 0 Then
'選択フォルダのPIDをパス名に変換
If SHGetPathFromIDList(lngFolderPID, strFolderPath) <> 0 Then
'NULL文字を削除
F_strSHBrowseForFolder = _
Left$(strFolderPath, InStr(strFolderPath, vbNullChar) - 1)
End If
'選択フォルダPIDのメモリを開放
Call CoTaskMemFree(lngFolderPID)
End If
End Function
Sub Test()
MsgBox F_strSHBrowseForFolder("", , BIF_NEWDIALOGSTYLE Or BIF_NONEWFOLDERBUTTON)
End Sub
|
|
![[未読]](./data/FAQ/image/read_icon.gif){kind=icon}
