フォルダを選択するダイアログ

---

フォルダを選択するダイアログボックスを表示するにはいくつかの方法があります。

1.FileDialogオブジェクトを使う方法

Sub Sample1()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            MsgBox .SelectedItems(1)
        End If
    End With
End Sub

2.Shellを使う方法

Sub Sample2()
    Dim Shell, myPath
    Set Shell = CreateObject("Shell.Application")
    Set myPath = Shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\")
    If Not myPath Is Nothing Then MsgBox myPath.Items.Item.Path
    Set Shell = Nothing
    Set myPath = Nothing
End Sub

3.APIを使う方法(1)

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
                                        (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
                                        (lpBrowseInfo As BROWSEINFO) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Public Type BROWSEINFO
    hOwner 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

Sub Sample3()
    Dim buf As String
    buf = GetFolder("フォルダを選択してください")
    If buf = "" Then Exit Sub
    MsgBox buf
End Sub

Function GetFolder(Optional Msg) As String
    Dim bInfo As BROWSEINFO, pPath As String
    Dim R As Long, X As Long, pos As Integer
    bInfo.pidlRoot = 0&
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "フォルダの選択..."
    Else
        bInfo.lpszTitle = Msg
    End If
    bInfo.ulFlags = &H1
    X = SHBrowseForFolder(bInfo)
    pPath = Space$(512)
    R = SHGetPathFromIDList(ByVal X, ByVal pPath)
    If R Then
        pos = InStr(pPath, Chr$(0))
        GetFolder = Left(pPath, pos - 1)
    Else
        GetFolder = ""
    End If
End Function

4.APIを使う方法(2)

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
                                    (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
                                    (lpBrowseInfo As BROWSEINFO) As Long
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
Public Const WM_USER = &H400
Public Const BFFM_SETSELECTIONA = (WM_USER + 102)
Public Const BFFM_INITIALIZED = 1
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As String    ''初期フォルダを指定するときはStringにする
    iImage As Long
End Type

Sub Sample4()
    Dim buf As String
    buf = GetDirectory("フォルダを選択してください", "E:\Develop")
    If buf = "" Then
        Exit Sub
    Else
        MsgBox buf
    End If
End Sub

Function GetDirectory(Optional Msg, Optional UserPath) As String
    Dim bInfo As BROWSEINFO, pPath As String
    Dim R As Long, X As Long, pos As Integer
    With bInfo
        .pidlRoot = &H0
        If IsMissing(Msg) Then
            .lpszTitle = "フォルダの選択..."
        Else
            .lpszTitle = Msg
        End If
        .ulFlags = &H40
        .lpfn = FARPROC(AddressOf BrowseCallbackProc)
        If IsMissing(UserPath) Then
            .lParam = CurDir & Chr(0)   ''またはvbNullChar
        Else
            .lParam = UserPath & Chr(0)
        End If
    End With
    X = SHBrowseForFolder(bInfo)
    pPath = Space$(512)
    R = SHGetPathFromIDList(ByVal X, ByVal pPath)
    CoTaskMemFree X
    If R 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(pfn As Long) As Long    ''AddressOf演算子の戻り値を戻す関数
    FARPROC = pfn
End Function

お好きな方法をどうぞ。