unit DirectoryDialog;

interface

uses
SysUtils, Classes, Dialogs, FileCtrl;

type
TDirectoryDialog = class(TCommonDialog)
private
  { Private declarations }
  FInitialDir: string;
  FTitle: string;
  FSelectDir:String;
  FCleanUp:Boolean;
  procedure SetInitialDir(const Value: string);
protected
  { Protected declarations }
public
  { Public declarations }
  constructor Create(AOwner: TComponent); override;
  destructor Destroy; override;
  function Execute: Boolean; override;
  property SelectedDir:string read FSelectDir write FSelectDir;
published
  { Published declarations }
  property InitialDir: string read FInitialDir write SetInitialDir;
  property Title: string read FTitle write FTitle;
  property CleanUpLastFolder:Boolean read FCleanUp write FCleanUp;
end;

procedure Register;

implementation

constructor TDirectoryDialog.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Title:='Быберите директорию...';
end;

destructor TDirectoryDialog.Destroy;
begin
inherited Destroy;
end;

function TDirectoryDialog.Execute: Boolean;
begin
if CleanUpLastFolder then
FSelectDir:='';
if (InitialDir='Desktop') then
Result:=FileCtrl.SelectDirectory(self.title,'',FSelectDir) else
Result:=FileCtrl.SelectDirectory(self.title,InitialDir,FSelectDir);
end;

procedure TDirectoryDialog.SetInitialDir(const Value: string);
var
L: Integer;
begin
L := Length(Value);
if (L > 1) and IsPathDelimiter(Value, L)
  and not IsDelimiter(':', Value, L - 1) then Dec(L);
FInitialDir := Copy(Value, 1, L);
end;

procedure Register;
begin
RegisterComponents('Components', [TDirectoryDialog]);
end;

end.

function SelectDirectory(const Caption: string; const Root: WideString;
 var Directory: string; Options: TSelectDirExtOpts = [sdNewUI]; Parent: TWinControl = nil): Boolean; overload;

function AdvSelectDirectory(const Caption: string;
                           const Root: WideString;
                           var Directory: string;
                           EditBox: Boolean = False;
                           ShowFiles: Boolean = False;
                           AllowCreateDirs: Boolean = True): Boolean;

 // callback функция, которая вызывается при инициализации диалога
 // или когда создается новая папка

 function SelectDirCB(Wnd: HWND; uMsg: UINT;
   lParam, lpData: lParam): Integer; stdcall;
 var
   PathName: array[0..MAX_PATH] of Char;
 begin
   case uMsg of
     BFFM_INITIALIZED:
       SendMessage(Wnd, BFFM_SETSELECTION, Ord(True), Integer(lpData));
     // включите этот код, если хотите реагировать на выбор новой папки
     {BFFM_SELCHANGED:
     begin
       SHGetPathFromIDList(PItemIDList(lParam), @PathName);
       // папки "PathName" была выбрана
     end;}
    end;
    Result := 0;
  end;
var
 WindowList: Pointer;
 BrowseInfo: TBrowseInfo;
 Buffer: PChar;
 RootItemIDList, ItemIDList: PItemIDList;
 ShellMalloc: IMalloc;
 IDesktopFolder: IShellFolder;
 Eaten, Flags: LongWord;

const
 BIF_USENEWUI = $0040;
 BIF_NOCREATEDIRS = $0200;

begin
 Result := False;
 if not DirectoryExists(Directory) then Directory := '';
 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(Application.Handle, nil,
       POleStr(Root), Eaten, RootItemIDList, Flags);
     end;
     OleInitialize(nil);
     with BrowseInfo do
     begin
       hwndOwner := Application.Handle;
       pidlRoot := RootItemIDList;
       pszDisplayName := Buffer;
       lpszTitle := PChar(Caption);
       // определяет то, как диалог будет появляться:
       ulFlags :=
         BIF_RETURNONLYFSDIRS or
         BIF_USENEWUI or
         BIF_EDITBOX * Ord(EditBox) or
         BIF_BROWSEINCLUDEFILES * Ord(ShowFiles) or
         BIF_NOCREATEDIRS * Ord(not AllowCreateDirs);
       lpfn    := @SelectDirCB;
       if Directory <> '' then lParam := Integer(PChar(Directory));
     end;
     WindowList := DisableTaskWindows(0);
     try
       ItemIDList := ShBrowseForFolder(BrowseInfo);
     finally
       EnableTaskWindows(WindowList);
     end;
     Result := ItemIDList <> nil;
     if Result then
     begin
       ShGetPathFromIDList(ItemIDList, Buffer);
       ShellMalloc.Free(ItemIDList);
       Directory := Buffer;
     end;
   finally
     ShellMalloc.Free(Buffer);
   end;
 end;
end;