Utilisation des codes de Jessy Sempere

Et oui c'est génial... ;-)

Voilà ce que j'ai gardé et enregistré dans un module que j'ai appelé
"modBrowseForFolder" vu que je suis sous access 97, j'ai aussi
copié telquel le mod "basAddressOf" du fichier excel.

La fonction a lancer est : DemoEXE()

'*******************************************************************
Option Compare Database
Option Explicit

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

Public Const WM_USER = &H400
Public Const MAX_PATH = 260

'** ulFlag constants
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_STATUSTEXT = &H4

'** Message from browser to callback function constants
Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SELCHANGED = 2
Public Const BFFM_VALIDATEFAILED = 3

'** Messages to browser from callback function
Public Const BFFM_SETSTATUSTEXTA = WM_USER + 100
Public Const BFFM_SETSELECTIONA = WM_USER + 102

Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

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

Public Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As
String) As Long

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

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest
As Any, _
hpvSource As Any, ByVal cbCopy As Long)

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Public Declare Function LocalAlloc Lib "kernel32" _
(ByVal uFlags As Long, _
ByVal uBytes As Long) As Long

Public Declare Function LocalFree Lib "kernel32" _
(ByVal hMem As Long) As Long

'** Déclaration pour centrer la boîte de dailogue
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
lpRect As RECT) As Long

Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long)
As Long

Public Const SM_CXFULLSCREEN = 16
Public Const SM_CYFULLSCREEN = 17

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long

Public CntrDialog As Boolean

Public Function GetDirectory(InitDir As String, Flags As Long, _
CntrDlg As Boolean, Msg) As String
Dim bInfo As BROWSEINFO
Dim pidl As Long, lpInitDir As Long

CntrDialog = CntrDlg
With bInfo
.pidlRoot = 0
.lpszTitle = Msg
.ulFlags = Flags
lpInitDir = LocalAlloc(LPTR, Len(InitDir) + 1)
CopyMemory ByVal lpInitDir, ByVal InitDir, Len(InitDir) + 1
.lParam = lpInitDir
.lpfn = AddrOf("BrowseCallBackFunc")
End With
'** Display the dialog
pidl = SHBrowseForFolder(bInfo)
'** Get path string from pidl
GetDirectory = GetPathFromID(pidl)
CoTaskMemFree pidl
LocalFree lpInitDir
End Function

'** Windows calls this function when the dialog events occur
Public Function BrowseCallBackFunc(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal lParam As Long, ByVal pData As Long) As Long
Select Case Msg
Case BFFM_INITIALIZED
'** Dialog is being initialized. I use this to set the initial
directory and
'** to center the dialog if the requested
SendMessage hwnd, BFFM_SETSELECTIONA, 1, pData
If CntrDialog Then CenterDialog hwnd
Case BFFM_SELCHANGED
'** User selected a folder - change status text
'** ("show status text" option must be set to see this)
SendMessage hwnd, BFFM_SETSTATUSTEXTA, 0, GetPathFromID(lParam)
Case BFFM_VALIDATEFAILED
'** This message is sent to the callback function only if
"Allow direct entry" and
'** "Validate direct entry" have been be set on the Demo
worksheet
'** and the user's direct entry is not valid.
'** "Show status text" must be set on to see error message we
send back to the dialog
Beep
SendMessage hwnd, BFFM_SETSTATUSTEXTA, 0, "Bad Directory"
BrowseCallBackFunc = 1 '** Block dialog closing
Exit Function
End Select
BrowseCallBackFunc = 0 '** Allow dialog to close
End Function

'** Converts a PIDL to a string
Public Function GetPathFromID(ID As Long) As String
Dim Result As Boolean, Path As String * MAX_PATH
Result = SHGetPathFromIDList(ID, Path)
If Result Then
GetPathFromID = Left(Path, InStr(Path, Chr$(0)) - 1)
Else
GetPathFromID = ""
End If
End Function

'** Centre la boîte de dialogue sur le bureau
Public Function CenterDialog(hwnd As Long)
Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
Dim DlgWidth As Integer, DlgHeight As Integer
GetWindowRect hwnd, WinRect
DlgWidth = WinRect.Right - WinRect.Left
DlgHeight = WinRect.Bottom - WinRect.Top
ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
(ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Function

Public Function DemoEXE()
Dim RetStr As String, Flags As Long
Flags = BIF_RETURNONLYFSDIRS
Flags = Flags + BIF_STATUSTEXT

RetStr = GetDirectory(CurDir, Flags, True, "Sélectionner le répertoire")
If RetStr <> "" Then MsgBox RetStr
End Function
'*******************************************************************
@+
Jessy Sempere - Access MVP
news@access.fr.vu
------------------------------------
Site @ccess : http://access.jessy.free.fr/
Pour l'efficacité de tous :
http://users.skynet.be/mpfa/
------------------------------------