Attribute VB_Name = "Module_GetFolder"
'Ce fichier a été téléchargé depuis
'http://www.vbfrance.com/article.aspx?ID=9144

Option Explicit

Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Const MAX_PATH = 260

Private Type BrowseInfo
    hwndOwner As Long
    pidlRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type

Public Enum BIF_Enum
    BIF_RETURNONLYFSDIRS = 1
    BIF_DONTGOBELOWDOMAIN = 2
    BIF_STATUSTEXT = 4
    BIF_RETURNFSANCESTORS = 8
    BIF_EDITBOX = 16
    BIF_VALIDATE = 32
    BIF_NEWDIALOGSTYLE = 64
    BIF_BROWSEINCLUDEURLS = 128
    BIF_USENEWUI = (BIF_EDITBOX Or BIF_NEWDIALOGSTYLE)
    BIF_BROWSEFORCOMPUTER = &H1000
    BIF_BROWSEFORPRINTER = &H2000
    BIF_BROWSEINCLUDEFILES = &H4000
    BIF_SHAREABLE = &H8000
End Enum

Public Function GetFolder(Title As String, OwnerHWnd As Long, Optional BIFMode As BIF_Enum = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI) As String
    Dim IDList As Long
    Dim Buf As String * MAX_PATH, BI As BrowseInfo

    With BI
        .hwndOwner = OwnerHWnd
        .lpszTitle = lstrcat(Title, vbNullChar)
        .ulFlags = BIFMode
    End With

    IDList = SHBrowseForFolder(BI)
    If IDList Then
        Call SHGetPathFromIDList(IDList, Buf)
        Call CoTaskMemFree(IDList)
        GetFolder = Split(Buf, vbNullChar)(0)
    End If
End Function


