1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
| Option Strict Off
Option Explicit On
Module mdlFolder
Delegate Function BrowseCallbackProcDlg(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
Private Structure BrowseInfo
Dim hWndOwner As Long
Dim pIDLRoot As Long
Dim pszDisplayName As Long
Dim lpszTitle As String
Dim ulFlags As Long
Dim lpfnCallback As BrowseCallbackProcDlg
Dim lParam As Long
End Structure
Private Declare Function SHGetPathFromIDList Lib "SHELL32.DLL" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "SHELL32.DLL" Alias "SHBrowseForFolderA" (ByRef lpBrowseInfo As BrowseInfo) As Long
Private Declare Function SHGetIDListFromPath Lib "SHELL32.DLL" Alias "#162" (ByVal szPath As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Long) As Long
Public Function GetFolderName(ByRef lngHandle_I As Long, ByVal strDefaultDirectory_I As String) As String
Dim lngIDList As Long
Dim strBuffer As String
Dim tBrowseInfo As new BrowseInfo()
Dim dlgCallBack As BrowseCallbackProcDlg
Const BIF_RETURNONLYFSDIRS As Short = 1
GetFolderName = ""
'Initialisation de la structure
dlgCallBack = new BrowseCallbackProcDlg(AddressOf BrowseCallbackProc)
With tBrowseInfo
.hWndOwner = lngHandle_I
.lpszTitle = "Sélectionner le répertoire"
.ulFlags = BIF_RETURNONLYFSDIRS
.lpfnCallback = dlgCallBack
.lParam = SHGetIDListFromPath(Convert.ToString(strDefaultDirectory_I))
End With
'Affichage de la fenêtre de sélection du répertoire
lngIDList = SHBrowseForFolder(tBrowseInfo)
'Récupération du répertoire sélectionné
If lngIDList Then
strBuffer = Space(512)
SHGetPathFromIDList(lngIDList, strBuffer)
GetFolderName = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
End If
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
Const BFFM_INITIALIZED As Short = 1
Const WM_USER As Long = &H400
Const BFFM_SETSELECTIONA As Decimal = (WM_USER + 102)
If uMsg = BFFM_INITIALIZED Then Call SendMessage(hWnd, BFFM_SETSELECTIONA, 0, lpData)
End Function
End Module |
[VB2008] structure BrowseInfo + repertoire par défaut
Répondre avec citation
Partager