[Excel] GetOpenFilename FileFilter=répertoire

Option Explicit
     Public 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
     '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

Function GetDirectory(Optional Msg) As String
     Dim bInfo As BROWSEINFO
     Dim path As String
     Dim r As Long, x As Long, pos As Integer
     bInfo.pidlRoot = 0&
     If IsMissing(Msg) Then
     bInfo.lpszTitle = "Choisissez un dossier de destination pour les sauvegardes."
     Else
     bInfo.lpszTitle = Msg
     End If
     bInfo.ulFlags = &H1
     x = SHBrowseForFolder(bInfo)
     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

dossier = GetDirectory("choisissez le dossier à traiter en Post-Publication")
If dossier <> "" Then .......

Public Sub Parcourir_Dossier()

Dim chemin As String
Dim TempDrive As String
Dim ThePath As String
Dim UserDir As String
Dim UserDrive As String

UserDrive = Left(CurDir, 1) 'On Mémorise les Paramètres du User
UserDir = CurDir  ' idem

chemin = ThisWorkbook.path

TempDrive = Left(chemin, 1) 'le lecteur mappé sur un serveur réseau
ThePath = chemin 'à ajuster au répertoire contenant tes classeurs

ChDrive TempDrive
ChDir ThePath

'Recupération du chemin et nom fichier d'extraction
chemin = Application.GetOpenFilename
Range("C17").Value = chemin

ChDrive UserDrive 'On remet les paramètres du User
ChDir UserDir 'idem

End Sub

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const BFFM_INITIALIZED = 1
Private Const WM_USER = &H400
Private Const BFFM_SETSELECTIONA = (WM_USER + 102)
 
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, _
    ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, _
    ByVal lpString2 As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                              (ByVal hWnd As Long, ByVal wMsg As Long, _
                              ByVal wParam As Long, lParam As Any) As Long
 
Private Declare Function SHGetIDListFromPath Lib "SHELL32.DLL" Alias "#162" (ByVal szPath As String) As Long
 
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
Function adr(n As Long) As Long
adr = n
End Function
 
Public Function BrowseCallbackProc(ByVal hWnd As Long, _
                                                      ByVal uMsg As Long, _
                                                      ByVal lParam As Long, _
                                                      ByVal lpData As Long) As Long
  If uMsg = BFFM_INITIALIZED Then
  'Quand la boite est ouverte actualise le chemin présélectionné
      Call SendMessage(hWnd, BFFM_SETSELECTIONA, False, ByVal lpData)
  End If
End Function
 
 
 
Public Function SelectFolder(Titre As String, Handle As Long, Racine As String) As String
 
Dim lpIDList As Long
Dim strBuffer As String
Dim strTitre As String
Dim tBrowseInfo As BrowseInfo
 
 
 
strTitre = Titre
With tBrowseInfo
    .hWndOwner = Handle
    .lpszTitle = lstrcat(strTitre, "")
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
    .lpfnCallback = adr(AddressOf BrowseCallbackProc)
    .lParam = SHGetIDListFromPath(StrConv(Racine, vbUnicode))
End With
 
lpIDList = SHBrowseForFolder(tBrowseInfo)
 
If (lpIDList) Then
    strBuffer = String(260, vbNullChar)
    SHGetPathFromIDList lpIDList, strBuffer
    SelectFolder = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
End If
 
End Function


Public Sub Repertoire()
  Range("C17").Value = SelectFolder("Choisir le répertoire par défaut", 0, ThisWorkbook.path)
End Sub