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

Option Compare Database
Option Explicit

Global Const CSIDL_DRIVES = 17
Type TBrInfo
    lngOwner As Long
    lngRoot As Long
    strDispName As String
    strTitle As String
    lngFlag As Long
    lngFn As Long
    lngParam As Long
    lngImage As Long
End Type

Declare Function SHBrowseForFolder Lib "Shell32" (lngL As TBrInfo) As Long
Declare Function SHGetPathFromIDList Lib "Shell32" _
                 Alias "SHGetPathFromIDListA" _
                 (ByVal lngP As Long, ByVal strPath As String) As Long

Public Function strZToStr(strX As String) As String
    strZToStr = Left$(strX, InStr(strX, vbNullChar) - 1)
End Function

Public Function BrFolder(strSeFolder As String, _
                         Optional varRoot As Variant, _
                         Optional varOptions As Variant, _
                         Optional varTitle As Variant, _
                         Optional varDisplayName As Variant, _
                         Optional varOwner As Variant) As Long

    Dim xxx As TBrInfo
    If Not IsMissing(varOwner) Then xxx.lngOwner = varOwner
    xxx.strDispName = String$(1024, 0)
    If IsMissing(varRoot) Then
        xxx.lngRoot = 0
    Else
        xxx.lngRoot = varRoot
    End If
    If Not IsMissing(varTitle) Then xxx.strTitle = varTitle
    If Not IsMissing(varOptions) Then xxx.lngFlag = varOptions

    Dim lngP As Long, strPath As String
    lngP = SHBrowseForFolder(xxx)
    If Not IsMissing(varDisplayName) Then varDisplayName = strZToStr(xxx.strDispName)
    strPath = String$(5120, 0)
    SHGetPathFromIDList lngP, strPath
    strSeFolder = strZToStr(strPath)
    BrFolder = lngP
End Function


'++++++   Use example +++++++++++

'    Dim strTitl As String, strDest As String, lngRet As Long
'    sTtl = "フォルダを選択してください。"
'    Do
'        lRet = BrFolder(strDest, , , strTitl, , Me.Hwnd)
'        If lngRet = False Then
'            Exit Do
'        ElseIf sDest = "" Then
'            If MsgBox("クリックでフォルダ選択してください。" & vbnewline _
                      & "選択を中止する場合はｷｬﾝｾﾙをクリックしてください。" _
                      , 64 + vbOKCancel) <> vbOK Then
'                lngRet = False
'                Exit Do
'            End If
'        End If
'    Loop Until lngRet And strDest > ""