フォルダ名の選択ウィンドウ

今回は、フォルダ名の選択ウィンドウを表示する方法を紹介しますが、少々、上級編になっています。

何故かというと、元々EXCELの機能にはないので、Windows APIといのを使用するからです。

Windows APIというのは、Windowsシステムのあらゆる機能が定義されている低レベルなサブルーチンの集まりです。
低レベルというのは、いわゆる、レベルが低いという意味ではなく、Windwosの基本的な機能を提供するという意味で捉えて下さい。

ですから、EXCELにない機能も実現できちゃたりするのです！
今回は、フォルダ名の選択ウィンドウを表示するのですが、複数のWindowsAPIを利用するので、結構、分かり辛いと思います。

Option Explicit

'InputFolder用
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

Public Function InputFolder( _
    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_InputFolder:

    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)
    InputFolder = strPath
Exit_InputFolder:
    Exit Function

Err_InputFolder:
    InputFolder = vbNullString
    Resume Exit_InputFolder:
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

フォルダ名の選択ウィンドウを表示するGetFolderNameの使用方法は、次回、紹介します。

それでは！