Selection de répertoire : valeur par défaut + bouton "créer"
Bonjour,
Dans une appli j'ouvre une fenêtre qui permet à l'utilisateur de choisir un répertoire. Il y a un répertoire racine, et un répertoire sélectionné par défaut.
Pour cela j'utilise ce code (source : Tofalu sur ce forum)
Code:
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
|
Option Compare Database
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const BFFM_INITIALIZED = 1
Private Const WM_USER = &H400
Private Const BFFM_SETSELECTIONA = (WM_USER + 102)
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 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 Function SHGetIDListFromPath Lib "SHELL32.DLL" Alias "#162" (ByVal szPath As String) As Long
Private Type 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
Function adr(n As Long) As Long
adr = n
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
If uMsg = BFFM_INITIALIZED Then
Call SendMessage(hWnd, BFFM_SETSELECTIONA, False, ByVal lpData)
End If
End Function
Public Function SelectFolder(Title As String, Handle As Long, DefaultFolder As String) As String
Dim lpIDList As Long
Dim strBuffer As String
Dim strTitle As String
Dim tBrowseInfo As BrowseInfo
strTitle = Title
With tBrowseInfo
.hWndOwner = Handle
.lpszTitle = lstrcat(strTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
.lpfnCallback = adr(AddressOf BrowseCallbackProc)
.lParam = SHGetIDListFromPath(StrConv(DefaultFolder, vbUnicode))
.pIDLRoot = SHGetIDListFromPath(StrConv("C:\", vbUnicode))
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
strBuffer = String(260, vbNullChar)
SHGetPathFromIDList lpIDList, strBuffer
SelectFolder = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
End If
End Function |
Ca fonctionne bien, mais quand j'essaye de rajouter un bouton de création de répertoire, avec ce code (source : Arkham46 sur ce forum aussi) ...
Code:
1
2
3
4
5
6
|
Private Const BIF_NEWDIALOGSTYLE As Long = &H40
...
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_NEWDIALOGSTYLE |
Le bouton est bien créé, le répertoire racine ("C:\") est toujours bon, mais le répertoire par défaut n'est plus selectionné.
Quelqu'un sait pourquoi ?
Merci pour votre aide. :)
