Const CSIDL_DESKTOP = &H0                   ' デスクトップ
Const BIF_RETURNONLYFSDIRS = &H1
Const BIF_DONTGOBELOWDOMAIN = &H2
Const MAX_PATH = 260                        ' ファイルパス長
Const WM_USER = &H400                       ' 初期フォルダの設定
Const BFFM_SETSELECTIONA = (WM_USER + 102)
Const BFFM_INITIALIZED = 1

Type BROWSEINFO
　　　hwndOwner       As Long               ' 呼び出し元ウインドウハンドル
　　　pidlRoot        As Long               ' 表示上のルートフォルダの位置
　　　pszDisplayName  As String             ' 選択されたフォルダ名
　　　lpszTitle       As String             ' ダイアログに表示する文字列
　　　ulFlags         As Long               ' ダイアログのオプションフラグ
　　　lpfn            As Long               ' コールバック関数のアドレス
　　　lParam          As Long               ' コールバック関数へ渡すパラメータ
　　　iImage          As Long
End Type

'******************************************************************************
'*  関数名：フォルダ選択ダイアログ（GetFolder）
'*  引　数：呼び出しフォーム（w_form As Form）
'*  　　　　ダイアログタイトル（ByVal w_title As String）
'*  　　　　選択フォルダ（w_path As String）
'*  戻り値：確定／キャンセル（Boolean）
'*  機　能：フォルダ選択ダイアログを表示し、フォルダを選択させる
'******************************************************************************
Public Function GetFolder(w_form As Form, w_title As String, w_path As String) _
        As Boolean

Dim w_ret             As Long               ' 戻り値
Dim w_tbrowseinfo     As BrowseInfo         ' フォルダダイアログ構造体
Dim w_buff            As String * MAX_PATH  ' パス名格納バッファ

    ' 呼び出し元ウインドウハンドルを設定
    w_tbrowseinfo.hWndOwner = W_form.hwnd
    ' デスクトップをルートに指定
    w_tbrowseinfo.pIDLRoot = CSIDL_DESKTOP
    ' ダイアログボックスの表示文字を設定
    w_tbrowseinfo.lpszTitle = W_title
    ' ダイアログボックスのオプションを設定
    w_tbrowseinfo.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN

    ' 初期表示ディレクトリが存在する場合
    If DirCheck(W_path) = True Then
        ' コールバック関数のアドレス
        W_tbrowseinfo.lpfn = FARPROC(AddressOf BrowseCallbackProc)
        ' 初期フォルダのパス名
        W_tbrowseinfo.lParam = W_path & vbNullChar
    End If
    ' ダイアログを表示する
    w_ret = SHBrowseForFolder(w_tbrowseinfo)
    ' フォルダが選択された場合
    If w_ret <> 0 Then
        ' パス名格納バッファを初期化
        w_buff = String$(MAX_PATH, vbNullChar)
        ' 返却されたID値をパス名に変換する
        w_ret = SHGetPathFromIDList(w_ret, w_buff)
        ' パス名の後ろのNullを削除します
        w_path = NullTrim(w_buff)
        
    Else
        ' 戻り値にキャンセルを設定
        GetFolder = False
    End If
    ' 割り当てられたメモリを解放する
    CoTaskMemFree W_ret

End Function

'******************************************************************************
'*  関数名：FARPROC処理（FARPROC）
'*  機　能：AddressOf演算子の戻り値を戻す
'******************************************************************************
Private Function FARPROC(pfn As Long) As Long

    FARPROC = pfn

End Function

'******************************************************************************
'*  関数名：コールバック処理（BrowseCallbackProc）
'*  機　能：フォルダ選択ダイアログを初期表示するためのアドレスを取得する
'******************************************************************************
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