Option Explicit
Option Private Module

'フォルダ指定ダイアログを開いてをフルパス文字列を返す

'*** API宣言
' 「フォルダの参照」ダイアログを開き、選択されたフォルダのID値を取得
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
                                    (lpBrowseInfo As BROWSEINFO) As Long
'取得したアイテムIDリストから、フォルダのフルパスを取得
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
                                    (ByVal pidl As Long, ByVal pszPath As String) As Long
'SHBrowseForFolder()で取得したアイテムIDリストのメモリを解放
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
'指定のウィンドウにメッセージを送る
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                                    (ByVal hWnd As Long, ByVal wMsg As Long, _
                                     ByVal wParam As Long, lParam As Any) As Long

'フォルダ指定ダイアログのUIパラメータ
Public Const WM_USER = &H400
Public Const BFFM_SETSELECTIONA = (WM_USER + 102)
Public Const BFFM_INITIALIZED = 1

'SHBrowseForFolder用の構造体を定義
Public Type BROWSEINFO
    hOwner As Long                         'オーナーウィンドウハンドル
    pidlRoot As Long                       'ルートディレクトリのアイテムIDリスト
    pszDisplayName As String               'フォルダ名
    lpszTitle As String                    'タイトルの下に書き込む文字列
    ulFlags As Long                        '表示についてのフラグ
    lpfn As Long                           'ダイアログからのメッセージを受け取るウィンドウプロシージャ
    lParam As String                       '初期フォルダを指定するときはStringにする
    iImage As Long                         '選択されたアイテムのアイコンの、システムイメージリスト内のインデックス
End Type


Function GetDirectory(Optional ByVal strMsg As String, _
                      Optional ByVal UserPath As String) As String
'フォルダ取得ダイアログを表示する関数
'
'■使い方
'string=GetDirectory(引数1,引数2)
'引数1:ダイアログに表示するメッセージ文字列 省略可
'引数2:初期ディレクトリ 省略時はデスクトップになる
'戻値:ディレクトリのフルパス
'
    Dim bInfo As BROWSEINFO         'APIに渡す構造体
    Dim pPath As String             'パスを格納
    Dim convResult As Long          'パス文字列への変換結果(TRUE:1 FALSE:0)
    Dim itemId As Long                   'アイテムID番号
    Dim pos As Integer
    
    With bInfo
        .pidlRoot = &H0                             'ルートフォルダを設定(デスクトップ)
        If IsMissing(strMsg) Then                   'ダイアログタイトルが設定されてるかを判定
            .lpszTitle = "フォルダの選択..."
        Else
            .lpszTitle = strMsg
        End If
        .ulFlags = &H1                                'フォルダ以外表示しない
        .lpfn = FARPROC(AddressOf BrowseCallbackProc) 'コールバック関数のアドレスを設定
        If IsMissing(UserPath) Then
            .lParam = ThisWorkbook.Path & Chr(0)      'カレントディレクトリを設定
        Else
            .lParam = UserPath & Chr(0)               '指定ディレクトリを設定
        End If
    End With
    
    '「フォルダの参照」ダイアログを開き、選択されたフォルダのID値を取得
    itemId = SHBrowseForFolder(bInfo)
    
    'パス格納領域をとりあえずスペースで埋める
    pPath = Space$(512)
    
    'SHBrowseForFolder APIで得られたID値をパス名に変換
    convResult = SHGetPathFromIDList(ByVal itemId, ByVal pPath)
    
    'アイテムIDを渡しメモリブロックを解放
    CoTaskMemFree itemId
    
    If convResult Then
        pos = InStr(pPath, Chr(0))
        GetDirectory = Left(pPath, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function


Public 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

Public Function FARPROC(ByVal pfn As Long) As Long
'AddressOf演算子の戻り値を戻す関数
' ※AddressOfは標準モジュールのプロシージャを指定しなければならないので、
' ダミーのプロシージャを実装する。
    FARPROC = pfn
End Function