'=======================================================
'フォルダリスト表示
'-------------------------------------------------------
't_mizu@mail.goo.ne.jpさんからの投稿 1999/03/01
'=======================================================
Option Compare Database
Option Explicit
'=====================================================================
' BrowseForFolder関連
'=====================================================================
Global Const CSIDL_DRIVES = 17
Type TBrowseInfo
        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

Declare Function SHBrowseForFolder Lib "Shell32" (lpbi As TBrowseInfo) As Long
Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal spath As String) As Long

Public Function StrZToStr(s As String) As String
        StrZToStr = Left$(s, InStr(s, Chr$(0)) - 1)
End Function

Public Function Browse_ForFolder(outSelectedFolder As String, _
    Optional vRoot As Variant, _
    Optional vOptions As Variant, _
    Optional vTitle As Variant, _
    Optional vDisplayName As Variant, _
    Optional vOwner As Variant) As Long

    Dim bi As TBrowseInfo
    If Not IsMissing(vOwner) Then bi.hwndOwner = vOwner
    bi.pszDisplayName = String$(1024, 0)
    If IsMissing(vRoot) Then
        bi.pidlRoot = 0 'CSIDL_DRIVES
    Else
        bi.pidlRoot = vRoot
    End If
    If Not IsMissing(vTitle) Then bi.lpszTitle = vTitle
    If Not IsMissing(vOptions) Then bi.ulFlags = vOptions
    ' bi.lpfn = 0
    ' bi.lParam = 0
    ' bi.iImage
    Dim pidl As Long, spath As String
    pidl = SHBrowseForFolder(bi)
    'pidl = 0 の場合「キャンセル」が押された
    If Not IsMissing(vDisplayName) Then vDisplayName = StrZToStr(bi.pszDisplayName)
    spath = String$(5120, 0)
    SHGetPathFromIDList pidl, spath
    outSelectedFolder = StrZToStr(spath)
    Browse_ForFolder = pidl
End Function