Sélection de dossier (API)

Parcourir et sélectionner un dossier - bis (API)

Retourne le nom du dossier sélectionné, mais permet en plus de renseigner un chemin par défaut

Usage :

Dim ChoixDossier As String
ChoixDossier = fn_RechDossier(Me.Hwnd, "Message", "D:/DossierSelectionné")

'/
'/ A placer dans la partie déclarative
'/
Option Compare Database
Option Explicit

'/--- DECLARATION DES API 's ---
Private Declare Function SHBrowseForFolder Lib "shell32" _
                                           (lpbi As BrowseInfo) As Long

'/ Dossier séléctionner.
Private Declare Function SHGetPathFromIDList Lib "shell32" _
               (ByVal pidList As Long, ByVal lpBuffer As String) As Long

'/ Pointeur du buffer.
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
              (ByVal lpString1 As String, ByVal lpString2 As String) As Long

'/ Envoie d'un message, à windows(destiné à la boite).

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
            (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
             ByVal lParam As String) As Long

'/ Positionnement de la boite.
Private Declare Function SetWindowPos Lib "user32" _
                    (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
                     ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
                     ByVal cy As Long, ByVal wFlags As Long) As Long

Private Const BIF_STATUSTEXT = &H4&
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)

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

Private msDosCour As String

La fonction :

Public Function fn_RechDossier(hndF As Long, sTitre As String, sDosDep As String) As String
    '/ Objectif :
    '/     Affiche une boite de dialogue équivalent au volet d'exploration
    '/     'Dossiers' de l'Explorateur. Elle permet d'obtenir le nom et le
    '/     chemin d'un répertoire choisi par l'utilisateur.
    '/     La sélection que d'une unité (C:) est possible.
    '/
    '/ ---> ENTRE
    '/      hndF    : Handler de la fenêtre qui appele la boite.
    '/      sTitre  : titre de la boite.
    '/      sDosDep : Dossier sélectionné à l'ouverture.
    '/
    '/ <--- SORT
    '/       Chemin et nom du répertoire sélectionné.
    '/
    Dim lpIDList As Long
    Dim szTitle As String
    Dim sBuffer As String
    Dim tBrowseInf As BrowseInfo

    msDosCour = sDosDep & vbNullChar
    szTitle = sTitre

    With tBrowseInf
        .hWndOwner = hndF
        .lpszTitle = lstrcat(szTitle, "")
        .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
        .lpfnCallback = fn_ObtenirAdrOf(AddressOf BrowseCallbackProc)
    End With

    '/ voir si l'utilisateur à sélectionné qq chose
    lpIDList = SHBrowseForFolder(tBrowseInf)

    If (lpIDList) Then
        '/ format et renvoie le chemin complet du dossier choisi.
        sBuffer = Space(MAX_PATH)
        SHGetPathFromIDList lpIDList, sBuffer
        sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        fn_RechDossier = sBuffer
    Else
        fn_RechDossier = ""
    End If

End Function

Private Function BrowseCallbackProc(ByVal hwnd As Long, _
                                    ByVal uMsg As Long, _
                                    ByVal lParam As Long, _
                                    ByVal lpData As Long) As Long

    Const SWP_NOSIZE As Long = 1
    Const SWP_NOZORDER As Long = 4
    Const XCoor As Long = 150  '/ in Pixeln
    Const YCoor As Long = 250  '/ in Pixeln
    Dim L As Long
    Dim ret As Long
    Dim sBuffer As String

    On Error Resume Next

    Select Case uMsg
        Case BFFM_INITIALIZED
            Call SendMessage(hwnd, BFFM_SETSELECTION, 1, msDosCour)
            L = SetWindowPos(hwnd, 0&, XCoor, YCoor, 0&, 0&, SWP_NOSIZE Or SWP_NOZORDER)
        Case BFFM_SELCHANGED
            sBuffer = Space(MAX_PATH)
            ret = SHGetPathFromIDList(lParam, sBuffer)

            If ret = 1 Then
                Call SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
            End If
    End Select

    BrowseCallbackProc = 0

End Function

'/ This function allows you to assign a function pointer to a vaiable.
Private Function fn_ObtenirAdrOf(add As Long) As Long
   fn_ObtenirAdrOf = add
End Function