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
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
| Option Explicit
'Module permettant d'affiche la fenêtre standard de sélection d'un répertoire
'Code récupéré sur le site http://vbnet.mvps.org/index.html
'--------------------------------------------------------------
' Copyright ©1996-2004 VBnet, Randy Birch, All Rights Reserved.
' Terms of use http://vbnet.mvps.org/terms/pages/terms.htm
'--------------------------------------------------------------
'
'common to both methods
Private 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
Private Declare Function SHBrowseForFolder Lib "shell32" _
Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(pDest As Any, _
pSource As Any, _
ByVal dwLength As Long)
Private Const MAX_PATH = 260
'---
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
'Selects the specified folder. If the wParam
'parameter is FALSE, the lParam parameter is the
'PIDL of the folder to select , or it is the path
'of the folder if wParam is the C value TRUE (or 1).
'Note that after this message is sent, the browse
'dialog receives a subsequent BFFM_SELECTIONCHANGED
'message.
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
'specific to the STRING method
Private Declare Function LocalAlloc Lib "kernel32" _
(ByVal uFlags As Long, _
ByVal uBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" _
(ByVal hMem As Long) As Long
Private Const LMEM_FIXED = &H0
Private Const LMEM_ZEROINIT = &H40
Private Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
Private Declare Function GetLogicalDriveStrings Lib "kernel32" _
Alias "GetLogicalDriveStringsA" _
(ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Private Enum BIF_Enum
BIF_RETURNONLYFSDIRS = 1
BIF_DONTGOBELOWDOMAIN = 2
BIF_STATUSTEXT = 4
BIF_RETURNFSANCESTORS = 8
BIF_EDITBOX = 16
BIF_VALIDATE = 32
BIF_NEWDIALOGSTYLE = 64
BIF_BROWSEINCLUDEURLS = 128
BIF_USENEWUI = (BIF_EDITBOX Or BIF_NEWDIALOGSTYLE)
BIF_BROWSEFORCOMPUTER = &H1000
BIF_BROWSEFORPRINTER = &H2000
BIF_BROWSEINCLUDEFILES = &H4000
BIF_SHAREABLE = &H8000
End Enum
Public Function SelectionRepertoire(ByVal Windows_hWnd As Long, _
Optional ByVal CheminParDefaut As String = "", _
Optional ByVal TitreFenetre As String = "") As String
Dim BI As BROWSEINFO
Dim pidl As Long
Dim lpSelPath As Long
Dim BIF As BIF_Enum
Dim spath As String * MAX_PATH
If CheminParDefaut = "" Then CheminParDefaut = CurDir
'the path used in the Browse function
'must be correctly formatted depending
'on whether the path is a drive, a
'folder, or "".
CheminParDefaut = FixPath(CheminParDefaut)
With BI
.hOwner = Windows_hWnd
.pidlRoot = 0
.lpszTitle = TitreFenetre
.lpfn = FARPROC(AddressOf BrowseCallbackProcStr)
lpSelPath = LocalAlloc(LPTR, Len(CheminParDefaut) + 1)
CopyMemory ByVal lpSelPath, ByVal CheminParDefaut, Len(CheminParDefaut) + 1
.lParam = lpSelPath
BIF = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI
.ulFlags = BIF
End With 'BI
pidl = SHBrowseForFolder(BI)
If pidl Then
If SHGetPathFromIDList(pidl, spath) Then
SelectionRepertoire = Left$(spath, InStr(spath, vbNullChar) - 1)
Else
SelectionRepertoire = ""
End If
Call CoTaskMemFree(pidl)
Else
SelectionRepertoire = ""
End If
Call LocalFree(lpSelPath)
End Function
Private Function FixPath(spath As String) As String
'The Browse callback requires the path string in a specific format - trailing slash if a
'drive only, or minus a trailing slash if a file system path. This routine assures the
'string is formatted correctly.
'
'In addition, because the calls to LocalAlloc requires a valid path for the call to succeed,
'the path defaults to C:\ if the passed string is empty.
'Test 1: check for empty string. Since we're setting it we can assure it is
'formatted correctly, so can bail.
If Len(spath) = 0 Then
FixPath = "C:\"
Exit Function
End If
'Test 2: is path a valid drive?
'If this far we did not set the path, so need further tests. Here we ensure
'the path is properly terminated with a trailing slash as needed.
'
'Drives alone require the trailing slash; file system paths must have it removed.
If IsValidDrive(spath) Then
'IsValidDrive only determines if the path provided is contained in
'GetLogicalDriveStrings. Since IsValidDrive() will return True
'if either C: or C:\ is passed, we need to ensure the string is formatted
'with the trailing slash.
FixPath = QualifyPath(spath)
Else
'The string passed was not a drive, so assume it's a path and ensure it does
'not have a trailing space.
FixPath = UnqualifyPath(spath)
End If
End Function
Private Function IsValidDrive(spath As String) As String
Dim buff As String
Dim nBuffsize As Long
'Call the API with a buffer size of 0.
'The call fails, and the required size is returned as the result.
nBuffsize = GetLogicalDriveStrings(0&, buff)
'pad a buffer to hold the results
buff = Space$(nBuffsize)
nBuffsize = Len(buff)
'and call again
If GetLogicalDriveStrings(nBuffsize, buff) Then
'if the drive letter passed is in the returned logical drive string, return True.
IsValidDrive = InStr(1, buff, spath, vbTextCompare)
End If
End Function
Private Function QualifyPath(spath As String) As String
If Len(spath) > 0 Then
If Right$(spath, 1) <> "\" Then
QualifyPath = spath & "\"
Else
QualifyPath = spath
End If
Else
QualifyPath = ""
End If
End Function
Private Function UnqualifyPath(spath As String) As String
'Qualifying a path involves assuring that its format is valid, including a trailing slash, ready for a
'filename. Since SHBrowseForFolder will not pre-select the path if it contains the trailing slash, it must be
'removed, hence 'unqualifying' the path.
If Len(spath) > 0 Then
If Right$(spath, 1) = "\" Then
UnqualifyPath = Left$(spath, Len(spath) - 1)
Exit Function
End If
End If
UnqualifyPath = spath
End Function
Private Function BrowseCallbackProcStr(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
'Callback for the Browse STRING method.
'On initialization, set the dialog's pre-selected folder from the pointer
'to the path allocated as bi.lParam, passed back to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTIONA, True, ByVal lpData)
Case Else
End Select
End Function
Private Function FARPROC(pfn As Long) As Long
'A dummy procedure that receives and returns the value of the AddressOf operator.
'This workaround is needed as you can't assign AddressOf directly to a member of a
'user-defined type, but you can assign it to another long and use that instead!
FARPROC = pfn
End Function |
CommonDialog bien spécifique
Répondre avec citation
Partager