Ooops sorry, that was my own classes functions. I just copied it here without
looking with details because it was running well in the projet I'm working on.
Here the corrected code :
'Begin ************************
Option Explicit
Option Private Module
Private Const BIF_STATUSTEXT As Long = &H4&
Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const BIF_DONTGOBELOWDOMAIN As Long = 2
Private Const MAX_PATH As Long = 260
Private Const WM_USER As Long = &H400
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_SETSTATUSTEXT As Long = (WM_USER +
100)
Private Const BFFM_SETSELECTION As Long = (WM_USER +
102)
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
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 Type BROWSEINFO
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
strWinTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private m_strCurrentDirectory As String
Public Function SelectAnyFolder(ByVal WindowTitle As String, ByVal
StartDirectory As String) As String
'---------------------------------------------------------------------------
' Procedure : BrowseForFolder
' DateTime : 14/09/2007
' Author : jp.ambrosino (argyronet)
' Purpose : Sélectionne un dossier dans l'arboresence de répertoires
'...........................................................................
' Parameters : StartDirectory = #
' WindowTitle = Window title
' Return Codes : String = Foldername
'...........................................................................
' Usage : Example
' strPath = SelectAnyFolder("Select a folder from
:","C:\WINDOWS")
'...........................................................................
' Evolutions : 21/04/2008 Updated for VB6 (JPA)
'---------------------------------------------------------------------------
Dim lngReturn As Long
Dim strBufferData As String
Dim tBI As BROWSEINFO
m_strCurrentDirectory = StartDirectory & vbNullChar
With tBI
.hwndOwner = 0
.strWinTitle = lstrcat(WindowTitle, " ")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN +
BIF_STATUSTEXT
.lpfnCallback = GetAddressOfFunction(AddressOf BrowseCallbackProc)
'get address of function.
End With
lngReturn = SHBrowseForFolder(tBI)
If (lngReturn) Then
strBufferData = Space(MAX_PATH)
SHGetPathFromIDList lngReturn, strBufferData
strBufferData = Left$(strBufferData, InStr(strBufferData,
vbNullChar) - 1)
SelectAnyFolder = strBufferData & "\"
Else
SelectAnyFolder = vbNullString
End If
End Function
Private Function GetAddressOfFunction(Ptr As Long) As Long
'---------------------------------------------------------------------------
' Procedure : GetAddressOfFunction
' DateTime : 14/09/2007 14:52
' Author : jp.ambrosino (argyronet)
' Purpose : Retourne un pointeur de fonction
'...........................................................................
' Parameters : Aucun
' Return Codes : Long = Pointeur de la fonction
'---------------------------------------------------------------------------
GetAddressOfFunction = Ptr
End Function
Private Function BrowseCallbackProc(ByVal Hwnd As Long, ByVal uMsg As Long,
ByVal lp As Long, ByVal pData As Long) As Long
'---------------------------------------------------------------------------
' Procedure : BrowseCallbackProc
' DateTime : 14/09/2007
' Author : jp.ambrosino (argyronet)
' Purpose : Function de callback
'...........................................................................
' Parameters : Aucun
' Return Codes : Long = Callback du process
'---------------------------------------------------------------------------
Dim lngRet As Long
Dim strBufferData As String
' Prevent an error from propagating back into the calling process.
On Error Resume Next
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(Hwnd, BFFM_SETSELECTION, 1,
m_strCurrentDirectory)
Case BFFM_SELCHANGED
strBufferData = Space(MAX_PATH)
lngRet = SHGetPathFromIDList(lp, strBufferData)
If lngRet = 0 Then
Call SendMessage(Hwnd, BFFM_SETSTATUSTEXT, 0, strBufferData)
End If
End Select
If Err <> 0 Then Err.Clear
BrowseCallbackProc = 0
End Function
Sub TestToSee()
MsgBox SelectAnyFolder("Your folder...", CurrentProject.Path)
End Sub
'End *************************
Regards
--
Argy
Goto :
http://argyronet.developpez.com/
Livres :
Créez des programmes avec Microsoft Access 2007 (ISBN 2742982442)
VBA pour Office 2007 (ISBN 2742983910)
