SHBrowseForFolder

Option Explicit
'----------------------------------------
'------Déclarations propres aux API------
'----------------------------------------
'---Les constantes---
Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const BIF_DONTGOBELOWDOMAIN As Long = 2
'---Les API---
Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32.dll" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
'---Les types---
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
'----------------------------------------------------------------------------------------------
'------Procédure permettant de sélectionner un répertoire par l'ouverture d'une boite    ------
'------de dialogue système                                                               ------
'----------------------------------------------------------------------------------------------
Private Function SelectionneRepertoire(sTitre As String, Handle As Long) As String
    '---Déclaration des variables---
    Dim lpIDList    As Long
    Dim sBuffer     As String
    Dim lpbi        As BrowseInfo
   
    '---Initialisation des paramètres de la boite de dialogue---
    With lpbi
        .hWndOwner = Handle
        .lpszTitle = lstrcat(sTitre, "")
        .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
    End With
   
    '---Ouvre la boite de dialogue---
    lpIDList = SHBrowseForFolder(lpbi)
   
    '---Retour---
    If (lpIDList) Then
        sBuffer = String(260, vbNullChar)
        SHGetPathFromIDList lpIDList, sBuffer
        SelectionneRepertoire = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
    Else
        SelectionneRepertoire = ""
    End If
End Function
'--------------------------------------
'------Procédures évènementielles------
'--------------------------------------
Private Sub Command1_Click()
    '---Selectionne un répertoire---
    Text1.Text = SelectionneRepertoire("Sélectionnez un répertoire :", Me.hWnd)
End Sub