'フォルダ名を取得する関数(SHBrowseForFolder)

Option Explicit

Private 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

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _
    ByVal PointerToIdList As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBROWSEINFO As BROWSEINFO) As Long
Private Declare Function CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Const CSIDL_DESKTOP As Long = 0
Private Const BIF_RETURNONLYFSDIRS As Long = &h1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &h2
Private Const MAX_PATH = 260

'フォルダ名を取得する関数(SHBrowseForFolder)
Function GetFolderName(ByVal hwnd As Long, _
        ByVal sPrompt As String, ByRef sPath As String) As Long
    Dim bi As BROWSEINFO
    Dim pidl As Long
    Dim iRet As Long

    GetFolderName = -1

    On Error GoTo ErrorHandler

    bi.hwndOwner = hwnd
    bi.pidlRoot = CSIDL_DESKTOP
    bi.pszDisplayName = String$(MAX_PATH + 1, Chr$(10))
    bi.lpszTitle = sPrompt
    bi.ulFlags = BIF_RETURNONLYFSDIRS
    bi.lpfn = 0
    bi.lParam = 0
    bi.iImage = 0

    pidl = SHBrowseForFolder(bi)
    If pidl = 0 Then
        GetFolderName = 1
        Exit Function
    End If

    sPath = String$(MAX_PATH + 1, Chr$(0))
    If SHGetPathFromIDList(ByVal pidl, ByVal sPath) = 0 Then
        iRet = CoTaskMemFree(pidl)
        Exit Function
    End If
    sPath = Left(sPath, InStr(sPath, Chr$(0)) - 1)
    iRet = CoTaskMemFree(pidl)
    If iRet <> 0 Then GetFolderName = 0
    Exit Function

ErrorHandler:
    If pidl <> 0 Then CoTaskMemFree pidl
End Function


Sub Test()
    Dim sPath As String
    Dim hwnd As Long
    Dim iRet As Long

    'Excelから実行する場合
    hwnd = FindWindow("XLMAIN", Application.Caption)

    'Excel5.0/95 DialogSheetから実行する場合
    'hwnd = FindWindow("bosa_sdm_XL", ActiveDialog.DialogFrame.Caption)

    'Excel97 DialogSheetから実行する場合
    'hwnd = FindWindow("bosa_sdm_XL8", ActiveDialog.DialogFrame.Caption)

    'Excel97 UserFormから実行する場合
    'hwnd = FindWindow("ThunderXFrame", UserForm1.Caption)

    iRet = GetFolderName(hwnd, "フォルダを選択してください。", sPath)
    If iRet = 0 Then
        MsgBox sPath
    ElseIf iRet = 1 Then
        MsgBox "キャンセルされました。"
    Else
        MsgBox "エラーが発生しました。"
    End If
End Sub