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
| unit DirDialog;
(* Affiche une boite de sélection de répertoires
Utilisation :
procedure TF_Princ.Button2Click(Sender: TObject);
Var
H1 : HWND ;
Path1 : string ;
Caption1 : String ;
Root1 : string ;
uFlag1 : DWORD ;
Titre : String
Begin
H1 := F_Princ.Handle ;
uFlag1 := $65 ; ou $65 + $200 sans création de nouveau dossier
Caption1 := 'Sélectionnez un dossier' ; // Label supérieur
Titre := 'Choix d''un dossier' ; // Titre du dialogue
Path1 := RepApp ; // Répertoire initial et de sortie
Root1 := '' ; // Racine du bureau
SelectDirectoryEx(H1, Path1, Caption1, Root1, uFlag1, Titre) ;
End ; *)
Interface
Uses ShlObj, ActiveX, Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Grids, DBGrids, StdCtrls, DBCtrls, ComCtrls,
DB, Menus, ExtCtrls, Shellapi, Buttons, FileCtrl, StrUtils, ShellCtrls;
Function SelectDirectoryEx(hOwn: HWND; var Path: string; Caption, Root: string;
uFlag: DWORD = $65; Titre : String = 'Choix d''un dossier'): Boolean;
Var
Title : String ;
Implementation
{ ===================================================================== }
Function SelectDirectoryEx(hOwn: HWND; var Path: string; Caption, Root: string;
uFlag: DWORD = $65; Titre : String = 'Choix d''un dossier'): Boolean;
Const
// pour uFlag :
BIF_NEWDIALOGSTYLE = $0040; // Style moderne
BIF_NONEWFOLDERBUTTON = $0200 ; // pas de création de répertoire
BIF_VALIDATE = $0020 ; // Possibilité de message d'erreur
BIF_RETURNONLYFSDIRS = $0001 ; // Bouton Ok grisé si pas de sélection
BIF_STATUSTEXT = $0004 ; // Affichage d'un label haut
var
BrowseInfo: TBrowseInfo;
Buffer: PChar;
RootItemIDList, ItemIDList: PItemIDList;
ShellMalloc: IMalloc;
IDesktopFolder: IShellFolder;
Dummy: LongWord;
{ ---------------------------------------------------------------- }
function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: Cardinal;
lpData: Cardinal): Integer; stdcall;
var
PathName: array[0..MAX_PATH] of Char;
begin
case uMsg of
BFFM_INITIALIZED:
Begin
SendMessage(Hwnd, BFFM_SETSELECTION, Ord(True), Integer(lpData));
SetWindowText(Hwnd, Pchar(Title));
End ;
BFFM_SELCHANGED:
begin
SHGetPathFromIDList(PItemIDList(lParam), @PathName);
SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, Longint(PChar(@PathName)));
end;
end;
Result := 0;
end;
{ ---------------------------------------------------------------- }
begin
Title := Titre ;
Result := False;
FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
begin
Buffer := ShellMalloc.Alloc(MAX_PATH);
try
RootItemIDList := nil;
if Root <> '' then
begin
SHGetDesktopFolder(IDesktopFolder);
IDesktopFolder.ParseDisplayName(hOwn, nil, POleStr(WideString(Root)),
Dummy, RootItemIDList, Dummy);
end;
with BrowseInfo do
begin
hwndOwner := hOwn;
pidlRoot := RootItemIDList;
pszDisplayName := Buffer;
lpszTitle := PChar(Caption);
ulFlags := uFlag;
lpfn := @BrowseCallbackProc;
lParam := Integer(PChar(Path));
end;
ItemIDList := ShBrowseForFolder(BrowseInfo);
Result := ItemIDList <> nil;
if Result then
begin
ShGetPathFromIDList(ItemIDList, Buffer);
ShellMalloc.Free(ItemIDList);
Path := StrPas(Buffer);
end;
finally
ShellMalloc.Free(Buffer);
end;
end;
end;
{ ======================================================================= }
end. |
