CommonDialog に FolderBrowserDialog

'/* FolderBrowserDialog クラス モジュール */
Option Explicit

' SHBrowseForFolder 関数
Private Declare Function SHBrowseForFolder Lib "SHELL32.DLL" Alias "SHBrowseForFolderA" ( _
    ByRef lpBrowseInfo As TypeBrowseInfo _
) As Long

' SHGetPathFromIDList 関数
Private Declare Function SHGetPathFromIDList Lib "SHELL32.DLL" Alias "SHGetPathFromIDListA" ( _
    ByVal pidl    As Long,  _
    ByVal pszPath As String _
) As Long

' CoTaskMemFree 関数
Private Declare Sub CoTaskMemFree Lib "OLE32.DLL" (ByVal pv As Long)

' BrowseInfo 構造体
Private Type TypeBrowseInfo
    OwnerHandle As Long
    Root        As Long
    DisplayName As String
    Description As String
    Flags       As BifOptions
    lpfn        As Long
    lParam      As String
    iImage      As Long
End Type

' FolderBrowseDialog 設定用の列挙体
Private Enum BifOptions
    ReturnOnlyFileSystemDirectories = &H1     ' コントロールパネル・プリンタ・ブリーフケース内は選択不可
    HideNetworkResource             = &H2     ' ネットワーク内のリソースを非表示
    StatusText                      = &H4     ' テキスト文字列を表示 (設定は Callback 関数で行う)
    OnlyNetworkResource             = &H8     ' ネットワーク内のリソースのみ選択可能
    ShowEditBox                     = &H10    ' フォルダ名を編集する TextBox を表示
    Validate                        = &H20    ' 検証を実行する
    NewDialogStyle                  = &H40    ' 新しいフォルダの作成を表示 (Winodws 2000 以降から有効)
    BrowseForComputer               = &H1000  ' ネットワークコンピュータ内のリソースのみ選択可
    BrowseForPrinter                = &H2000  ' ネットワークプリンタのみ選択可
    BrowseIncludeFiles              = &H4000  ' フォルダ内のファイル名も表示 (Windows 98 以降)
End Enum

' プロパティ 変数
Private m_SelectedPath As String
Private BrowseInfo     As TypeBrowseInfo

' SelectedPath - Get
Public Property Get SelectedPath() As String
    SelectedPath = m_SelectedPath
End Property

' SelectedPath - Let
Public Property Let SelectedPath(ByVal value As String)
    m_SelectedPath = value
End Property

' Description - Get
Public Property Get Description() As String
    Description = BrowseInfo.Description
End Property

' Description - Let
Public Property Let Description(ByVal value As String)
    BrowseInfo.Description = value
End Property

' ShowNewFolderButton - Get
Public Property Get ShowNewFolderButton() As Boolean
    ShowNewFolderButton = ((BrowseInfo.Flags And NewDialogStyle) > 0)
End Property

' ShowNewFolderButton - Let
Public Property Let ShowNewFolderButton(ByVal value As Boolean)
    If value Then
        BrowseInfo.Flags = BrowseInfo.Flags Or NewDialogStyle
    Else
        BrowseInfo.Flags = BrowseInfo.Flags And Not NewDialogStyle
    End If
End Property

' コンストラクタ
Private Sub Class_Initialize()
    BrowseInfo.Flags = BrowseInfo.Flags Or NewDialogStyle
End Sub

'「フォルダの参照」ダイアログを表示する
Public Function ShowDialog(Optional ByVal hOwnerHandle As Long = 0&) As Boolean
    Dim lReturn As Long

    ' 親ハンドルを設定する
    BrowseInfo.OwnerHandle = hOwnerHandle

    '「フォルダの参照」ダイアログを呼び出す
    lReturn = SHBrowseForFolder(BrowseInfo)

    ' OK が押下された場合
    If lReturn <> 0 Then
        Dim stPath As String

        stPath = String$(65536, vbNullChar)

        Call SHGetPathFromIDList(lReturn, stPath)
        Call CoTaskMemFree(lReturn)

        Me.SelectedPath = Left$(stPath, InStr(stPath, vbNullChar) - 1)
        ShowDialog = True
    End If
End Function

使用例は以下のようになります。

 ' FolderBrowserDialog クラスの新しいインスタンスを生成する
    Dim cFolderBrowserDialog As FolderBrowserDialog
    Set cFolderBrowserDialog = New FolderBrowserDialog

    ' ダイアログの説明を設定する
    cFolderBrowserDialog.Description = "ここに説明を書いてください"

    ' [新しいフォルダ] ボタンを表示する (初期値 True)
    'cFolderBrowserDialog.ShowNewFolderButton = True

    ' ダイアログを表示し、戻り値が [OK] の場合は、選択したディレクトリを表示する
    If cFolderBrowserDialog.ShowDialog(Me.hWnd) Then
        Call MsgBox(cFolderBrowserDialog.SelectedPath)
    End If

    ' 不要になった時点で参照を解放する (Terminate イベントを早めに起こす)
    Set cFolderBrowserDialog = Nothing