BrowseFoldersRoutine

'# $FICHIER : BrowseFolder.bas
'# $VERSION : v1.0
'#
'# HISTORI/UE DES MODIFICATIONS/
'#  v1.0   OD   14/05/1999  Cr�ation
'###################################
Option Explicit
'Constantes
Private Const BIF_RETURNONLYFSDIRS = &H1        'Uniquement des r�pertoire
Private Const BIF_DONTGOBELOWDOMAIN = &H2       'Domaine globale intredit
Private Const BIF_STATUSTEXT = &H4              'Zone de saisie autoris�e
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_EDITBOX = &H10                'Zone de saisie autoris�e
Private Const BIF_VALIDATE = &H20               'insist on valid result (or CANCEL)
Private Const BIF_BROWSEFORCOMPUTER = &H1000    'Uniquement des PCs.
Private Const BIF_BROWSEFORPRINTER = &H2000     'Uniquement des imprimantes
Private Const BIF_BROWSEINCLUDEFILES = &H4000   'Browsing for Everything
Private Const MAX_PATH = 260
'Types
Private Type T_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
'Fonctions API Windows
Private Declare Function SHBrowseForFolder Lib "shell32" _
    (lpbi As T_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
'###################################
'*  BrowseFolder :
'*  Entr�es :   - HwndOwner     : Handle de la fen�tre appelante
'*              - Titre         : Titre
'*  Sorties :
'*              - string contenant le chemin complet ou Chaine vide (si annulation)
'*
'*  Affiche une boite de dialogue permettant la s�lection d'un r�pertoire.
'*  Renvoie une chaine vide si l'op�rateur annule.
'###################################
Public Function BrowseFolder(ByVal HwndOwner As Long, ByRef Titre As String) As String
    Dim lpIDList As Long
    Dim sBuffer As String
    Dim BrowseInfo As T_BROWSEINFO
    'Initialise l'affichage
    BrowseFolder = ""
    With BrowseInfo
        .HwndOwner = HwndOwner
        .lpszTitle = lstrcat(Titre, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    'Affiche la boite de dialogue
    lpIDList = SHBrowseForFolder(BrowseInfo)
    'R�cup�re le r�pertoire s�lectionn�
    If (lpIDList) Then
        sBuffer = Space(MAX_PATH)
        SHGetPathFromIDList lpIDList, sBuffer
        sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        BrowseFolder = sBuffer
    End If
End Function

'# $FICHIER : BrowseFolder.bas

'# $VERSION : v1.0

'#

'# HISTORI/UE DES MODIFICATIONS/

'# v1.0 OD 14/05/1999 Cre'ation

'###################################

Option Explicit
'Constantes

Private Const BIF_RETURNONLYFSDIRS = &H1 'Uniquement des re'pertoire
Private Const BIF_DONTGOBELOWDOMAIN = &H2 'Domaine globale intredit
Private Const BIF_STATUSTEXT = &H4 'Zone de saisie autorise'e
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_EDITBOX = &H10 'Zone de saisie autorise'e
Private Const BIF_VALIDATE = &H20 'insist on valid result (or CANCEL)
Private Const BIF_BROWSEFORCOMPUTER = &H1000 'Uniquement des PCs.
Private Const BIF_BROWSEFORPRINTER = &H2000 'Uniquement des imprimantes
Private Const BIF_BROWSEINCLUDEFILES = &H4000 'Browsing for Everything
Private Const MAX_PATH = 260
'Types

Private Type T_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
'Fonctions API Windows

Private Declare Function SHBrowseForFolder Lib "shell32" _
(lpbi As T_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
'###################################

'* BrowseFolder :

'* Entre'es : - HwndOwner : Handle de la fen�tre appelante

'* - Titre : Titre

'* Sorties :

'* - string contenant le chemin complet ou Chaine vide (si annulation)

'*

'* Affiche une boite de dialogue permettant la se'lection d'un re'pertoire.

'* Renvoie une chaine vide si l'ope'rateur annule.

'###################################

Public Function BrowseFolder(ByVal HwndOwner As Long, ByRef Titre As String) As String
Dim lpIDList As Long
Dim sBuffer As String
Dim BrowseInfo As T_BROWSEINFO
'Initialise l'affichage

BrowseFolder = ""
With BrowseInfo
.HwndOwner = HwndOwner
.lpszTitle = lstrcat(Titre, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
'Affiche la boite de dialogue

lpIDList = SHBrowseForFolder(BrowseInfo)
'Re'cupe're le re'pertoire se'lectionne'

If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
BrowseFolder = sBuffer
End If
End Function