Sub Ouvrir_Boite_Dialogue()
    Application.FileDialog(msoFileDialogFolderPicker).Show
End Sub

Sub Rep_Selection ()
Dim Rep As String
    Application.FileDialog(msoFileDialogFolderPicker).Show
    Rep = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    MsgBox Rep
End Sub

'Constantes permettant de personnaliser le fonctionnement de BrowseForFolder
Const BIF_RETURNONLYFSDIRS = &H1 'pour chercher les fichiers systèmes seulement
                                    ' si le dossier sélectionné ne contient pas
                                    ' de fichier système alors le bouton "OK" est grisé
Const BIF_DONTGOBELOWDOMAIN = &H2 'interdit d'explorer en dehors du domaine 'For starting the Find Computer
Const BIF_STATUSTEXT = &H4 '
Const BIF_RETURNFSANCESTORS = &H8 'seulement des dossiers
Const BIF_EDITBOX = &H10 'Affiche une zone d'édition
Const BIF_VALIDATE = &H20 'Vérifie la saisie dans la zone d'édition
Const BIF_BROWSEFORCOMPUTER = &H1000 'Autorise le parcours réseau
Const BIF_BROWSEFORPRINTER = &H2000 'mes documents et bureau uniquemnet
Const BIF_BROWSEINCLUDEFILES = &H4000 'dossiers et fichiers
Const BIF_NONEWFOLDERBUTTON = &H200 'ne pas mettre le bouton Nouveau dossier

'affiche la boite de dialogue Windows de recherche d'un dossier
'ou d'un fichier

Sub essai()
    Dim Choix As String
    Choix = ChoixDossierFichier(1)
    If Choix <> "" Then MsgBox Choix
End Sub

Function ChoixDossierFichier(bDos As Boolean) As String
    Dim objShell As Object, objFolder As Object
    Dim Chemin As String, Msg As String
    Dim FlagChoix As Long, NbPoint As Integer

    If bDos Then
      FlagChoix = BIF_RETURNFSANCESTORS
      Msg = "Sélectionner un dossier :"
    Else
      FlagChoix = BIF_BROWSEINCLUDEFILES + BIF_NONEWFOLDERBUTTON
      Msg = "Sélectionner un fichier :"
    End If
                                            
    Set objShell = CreateObject("Shell.Application")
' 1er paramètre toujours 0 (zéro). Il représente le handle de la fenêtre parent
' 2ème paramètre Titre de la boite, en dessous de la barre de titre
' 3ème paramètre options de BrowseForFolder
' 4ème paramètre Facultatif. Répertoire de début d'exploration
    On Error Resume Next
    Set objFolder = objShell.BrowseForFolder(&H0&, Msg, FlagChoix)
    'Si l 'objet retourné est valide, on teste son contenu (item.title)
    'Si on a sélectionné la racine d'une partition, il se compose du nom de la partition,
    ' suivi de sa lettre et ":" entre parenthèses
    NbPoint = InStr(objFolder.Title, ":")
    If NbPoint = 0 Then
        'Sinon, il se compose du nom du dossier uniquement, sans le chemin précédent
        'On récupère ce chemin à l'aide des propriété et méthode ParentFolder.ParseName
        Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
    Else
        ' si racine on récupère la lettre du lecteur et les 2 points
        Chemin = Mid(objFolder.Title, NbPoint - 1, 2)
    End If
    ChoixDossierFichier = Chemin
End Function

'-----------------------------------------------------------------
' Variables utilisées pour l'affichage de la boîte de dialogue de 
' recherche de dossier
'-----------------------------------------------------------------
Public Type BROWSEINFO
    hOwner 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

'-----------------------------------------------------------------
' Variables utilisées pour 32-bit API declarations
'-----------------------------------------------------------------
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
  pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

'-----------------------------------------------------------------
' Procédure d'appel de la fonction
'-----------------------------------------------------------------
Sub Procedure_Appel()
Dim Msg As String
    Msg = "Sélectionner le répertoire de traitement."
    
' Appel de la fonction qui retourne le nom du chemin d'accès du 
'  répertoire en mettant en paramètre le titre de la fenêtre.
    Cells(1, 1) = GetDirectory(Msg)
    
End Sub

'------------------------------------------------------------------
' Fonction qui va afficher une boîte de dialogue pour sélectionner
' un répertoire
'------------------------------------------------------------------
Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim Path As String
    Dim R As Long, x As Long, pos As Integer
 
'   Répertoire par défaut le bureau
    bInfo.pidlRoot = 0&

'   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
    End If
    
'   Type de repertoire sélectionné
'   En Annexe 3, vous trouverez tous les codes existants
'   d'autres répertoires comme le répertoire Mes Documents, SendTo, …
    bInfo.ulFlags = &H1

'   Affichage de la boîte de dialogue
    x = SHBrowseForFolder(bInfo)
    
'   Décomposition du résultat
    Path = Space$(512)
    R = SHGetPathFromIDList(ByVal x, ByVal Path)
    If R Then
        pos = InStr(Path, Chr$(0))
        GetDirectory = Left(Path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function