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. |
Partager