フォルダー選択ダイアログを表示

メモ ProgrammingTips

VisualBasic6用
フォルダー選択ダイアログを表示

' フォルダー選択ダイアログを表示
'  *** この内容を標準モジュールに作成してください ***
' strTitle    : ダイアログのタイトル
' lngOwnerHwnd: 親ウィンドウのウィンドウハンドル
' lngRoot     : ルートフォルダーの指定
' lngFlags    : 表示形態の指定
' strParam    : 初期状態選択フォルダー

Option Explicit

Private Const MAX_PATH            As Long = 260
Private Const BFFM_SETSTATUSTEXTA As Long = &H464&  ' ステータステキスト
Private Const BFFM_ENABLEOK       As Long = &H465&  ' OK ボタンの使用可否
Private Const BFFM_SETSELECTIONA  As Long = &H466&  ' アイテムを選択
Private Const BFFM_INITIALIZED    As Long = &H1&
Private Const BFFM_SELCHANGED     As Long = &H2&
Private Type RECT
        left As Long    'WindowのX座標
        top As Long     'WindowのY座標
        right As Long   'Windowの右端の座標
        bottom As Long  'Windowの底にあたる部分の座標
End Type
Private Type BROWSEINFO
    hWndOwner       As Long     'ダイアログの親ウィンドウのハンドル
    pidlRoot        As Long     'ディレクトリツリーのルート
    pszDisplayName  As String   'MAX_PATH
    lpszTitle       As String   'ダイアログの説明文
    ulFlags         As Long     'ENUM_FLAGS_FOLDER
    lpfn            As Long     'コールバック関数へのポインタ
    lParam          As String   'コールバック関数へのパラメータ
    iImage          As Long     'フォルダーアイコンのシステムイメージリスト
End Type
Public Enum ENUM_ROOT_FOLDER
    CSIDL_DESKTOP = &H0&                        ' デスクトップ
    CSIDL_INTERNET = &H1&                       ' インターネット
    CSIDL_PROGRAMS = &H2&                       ' Program Files
    CSIDL_CONTROLS = &H3&                       ' コントロールパネル
    CSIDL_PRINTERS = &H4&                       ' プリンタ
    CSIDL_PERSONAL = &H5&                       ' ドキュメントフォルダー
    CSIDL_FAVORITES = &H6&                      ' お気に入り
    CSIDL_STARTUP = &H7&                        ' スタートアップ
    CSIDL_RECENT = &H8&                         ' 最近使ったファイル
    CSIDL_SENDTO = &H9&                         ' 送る
    CSIDL_BITBUCKET = &HA&                      ' ごみ箱
    CSIDL_STARTMENU = &HB&                      ' スタートメニュー
    CSIDL_DESKTOPDIRECTORY = &H10&              ' デスクトップフォルダー
    CSIDL_DRIVES = &H11&                        ' マイコンピュータ
    CSIDL_NETWORK = &H12&                       ' ネットワーク(ネットワーク全体あり)
    CSIDL_NETHOOD = &H13&                       ' NETHOOD フォルダー
    CSIDL_FONTS = &H14&                         ' フォント
    CSIDL_TEMPLATES = &H15&                     ' テンプレート
    CSIDL_COMMON_STARTMENU = &H16&              '
    CSIDL_COMMON_PROGRAMS = &H17&               '
    CSIDL_COMMON_STARTUP = &H18&                '
    CSIDL_COMMON_DESKTOPDIRECTORY = &H19&       '
    CSIDL_APPDATA = &H1A&                       '
    CSIDL_PRINTHOOD = &H1B&                     '
    CSIDL_ALTSTARTUP = &H1D&                    '
    CSIDL_COMMON_ALTSTARTUP = &H1E&             '
    CSIDL_COMMON_FAVORITES = &H1F&              '
    CSIDL_INTERNET_CACHE = &H20&                '
    CSIDL_COOKIES = &H21&                       '
    CSIDL_HISTORY = &H22&                       '
End Enum
Enum ENUM_FLAGS_FOLDER
    BIF_RETURNONLYFSDIRS = &H1&          ' フォルダのみ
    BIF_DONTGOBELOWDOMAIN = &H2&         ' ネットワークコンピューターを非表示
    BIF_STATUSTEXT = &H4&                ' ステータス表示
    BIF_RETURNFSANCESTORS = &H8&
    BIF_BROWSEFORCOMPUTER = &H1000&      ' ネットワークコンピューターのみ
    BIF_BROWSEFORPRINTER = &H2000&       ' プリンターのみ
    BIF_BROWSEINCLUDEFILES = &H4000&     ' 全て選択可能
End Enum

Private Declare Function SHBrowseForFolder Lib "shell32" (ByRef lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
        (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SendMessageStr Lib "user32" Alias "SendMessageA" _
        (ByVal hWnd As Long, ByVal wMsg As Long, _
         ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHFree Lib "shell32" Alias "#195" (ByVal pidl As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long

'
' フォルダー選択ダイアログを表示
'   strTitle     : ダイアログに表示する説明文。
'   lngOwnerHwnd : ダイアログのオーナーウィンドウ。
'   lngRoot      : CSIDL_xxx の定数
'   lngFlags     : BIF_xxx の定数
'   strParam     : デフォルトのフォルダー名
' 戻値  正常終了 - フォルダー名 / 異常終了 - ""
'
Public Function GetFolderName( _
    Optional ByRef strTitle As String = "フォルダーを選択してください", _
    Optional ByVal lngOwnerHwnd As Long = 0&, _
    Optional ByVal lngRoot As ENUM_ROOT_FOLDER = CSIDL_DESKTOP, _
    Optional ByVal lngFlags As ENUM_FLAGS_FOLDER = BIF_RETURNONLYFSDIRS, _
    Optional ByRef strParam As String = vbNullString) As String

    On Error GoTo Err_GetFolderName:

    Dim biParam     As BROWSEINFO
    Dim pidl        As Long
    Dim strPath     As String

    If lngOwnerHwnd = 0& Then
        lngOwnerHwnd = GetDesktopWindow()
    End If

    strPath = String$(MAX_PATH, vbNullChar)

    With biParam
        .hWndOwner = lngOwnerHwnd
        .pidlRoot = lngRoot
        .pszDisplayName = strPath
        .lpszTitle = strTitle & vbNullChar
        .ulFlags = lngFlags
        If Len(strParam) > 0& Then
            
            .lpfn = GetLong(AddressOf BrowseCallbackProc)
            .lParam = strParam & vbNullChar
        End If
    End With

    pidl = SHBrowseForFolder(biParam)

    If biParam.ulFlags And BIF_BROWSEFORCOMPUTER Then
        strPath = biParam.pszDisplayName
        strPath = left$(strPath, InStr(strPath, vbNullChar) - 1&)
    Else
        If pidl = 0& Then
            strPath = vbNullString
        Else
            If SHGetPathFromIDList(pidl, strPath) <> 0& Then
                strPath = left$(strPath, InStr(strPath, vbNullChar) - 1&)
            Else
                strPath = vbNullString
            End If
        End If
    End If

    Call SHFree(pidl)
    GetFolderName = strPath
Exit_GetFolderName:
    Exit Function

Err_GetFolderName:
    GetFolderName = vbNullString
    Resume Exit_GetFolderName:
End Function
'
'
'   SHBrowseForFolder API のコールバック関数。
'
Private Function BrowseCallbackProc(ByVal lngHWnd As Long, ByVal lngUMsg As Long, _
                            ByVal lngLParam As Long, ByVal lngLpData As String) As Long
    Select Case lngUMsg
        Case BFFM_INITIALIZED
            Call SendMessageStr(lngHWnd, BFFM_SETSELECTIONA, 1&, StrConv(lngLpData, vbUnicode))
        'Case BFFM_SELCHANGED
        ' ITEMが選択された時に処理を行いたい場合ここに書きます
    End Select
    BrowseCallbackProc = 0&
End Function

Private Function GetLong(varAddr As Variant) As Long
    GetLong = CLng(varAddr)
End Function