Dialog do wyboru katalogu

Dialog do wyboru katalogu

Poniżej przedstawiam moduł, który należy dodać do sekcji uses, aby w łatwy sposób móc
obsłużyć okno wyboru katalogu SelectDirectory z modułu FileCtrl. Obsługa dla tego modułu
przypomina wywoływanie standardowych okienek takich jak OpenDialog czy SaveDialog.

Przykład uzycia:

procedure TForm1.Button1Click(Sender : TObject);
var
  BrowseDialog : TFolderBrowseDialog;
begin
  BrowseDialog := TFolderBrowseDialog.Create(Form1);
  BrowseDialog.InitialDir := 'C:\';
  BrowseDialog.PromptText := 'Wybierz katalog:';
  if BrowseDialog.Execute then
  begin
    ShowMessage(BrowseDialog.Directory);
  end;
end;

Jako parametr dla konstruktora Create, należy podać kontrolkę typu TWinControl, czyli najlepiej
nazwę formularza, na którym wywołujemy dialog do wyboru katalogu. Parametr ten jest ważny
dla użytkowników starszych wersji Delphi lub Windowsów '9X, gdzie tworzone okno dialogowe
nie pokazywało się zawsze na środku, jak ma to miejsce w późniejszych Windowsach NT czy XP.
Pod Windowsami '9x nie będzie również widocznego w oknie przycisku "Utwórz nowy folder".

Kod modułu (zapisz jako browse.pas):

unit browse;

interface

uses
  Forms, Windows, Controls, SysUtils, FileCtrl, ShlObj, ActiveX;

type
  TFolderBrowseDialog = class(TObject)
    FInitialDir : string;
    FPromptText : string;
    FDirectory : string;
    OwnerHwnd : HWND;
  public
    constructor Create(AOwner : TWinControl);
    destructor Destroy; override;
    property InitialDir : string read FInitialDir write FInitialDir;
    property PromptText : string read FPromptText write FPromptText;
    property Directory : string read FDirectory write FDirectory;
    function Execute : boolean;
  end;

implementation

type
  TSelectDirectoryProc = function(const Directory : string) : Boolean;

constructor TFolderBrowseDialog.Create(AOwner : TWinControl);
begin
  inherited Create;
  FPromptText := '';
  FInitialDir := '';
  OwnerHwnd := AOwner.Handle;
end;

destructor TFolderBrowseDialog.Destroy;
begin
  inherited Destroy;
end;

function TFolderBrowseDialog.Execute : boolean;

  function SelectDirectoryEx(var Path : string; const Caption, Root : string;
    BIFs : DWORD; Callback : TSelectDirectoryProc; const FileName : string) : Boolean;
  const
    BIF_NEWDIALOGSTYLE = $0040;
  type
    TMyData = packed record
      IniPath : PChar;
      FileName : PChar;
      Proc : TSelectDirectoryProc;
    end;
    PMyData = ^TMyData;
  var
    BrowseInfo : TBrowseInfo;
    Buffer : PChar;
    RootItemIDList, ItemIDList : PItemIDList;
    ShellMalloc : IMalloc;
    IDesktopFolder : IShellFolder;
    Dummy : DWord;
    Data : TMyData;

    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 :
          SendMessage(Hwnd, BFFM_SETSELECTION, Ord(True),
            Integer(PMyData(lpData).IniPath));
        BFFM_SELCHANGED :
          begin
            SHGetPathFromIDList(PItemIDList(lParam), @PathName);
            SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0,
              LongInt(PChar(@PathName)));
            if Assigned(PMyData(lpData).Proc) then
              SendMessage(hWnd, BFFM_ENABLEOK, 0,
                Ord(PMyData(lpData).Proc(PathName)))
            else
              if PMyData(lpData).FileName <> nil then
                SendMessage(hWnd, BFFM_ENABLEOK, 0,
                  Ord(FileExists(PathName)))
              else
                SendMessage(hWnd, BFFM_ENABLEOK, 0,
                  Ord(DirectoryExists(PathName)));
          end;
      end;
      Result := 0;
    end;

  begin
    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(GetActiveWindow, nil,
            POleStr(WideString(Root)), Dummy, RootItemIDList, Dummy);
        end;

        with BrowseInfo do
        begin
          hwndOwner := OwnerHwnd;
          pidlRoot := RootItemIDList;
          pszDisplayName := Buffer;
          lpszTitle := PChar(Caption);
          ulFlags := BIFs;
          lpfn := @BrowseCallbackProc;
          Data.IniPath := PChar(Path);
          if FileName <> '' then
            Data.FileName := PChar(FileName)
          else
            Data.FileName := nil;
          Data.Proc := Callback;
          lParam := Integer(@Data);
        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;

  function CallBack(const Path : string) : Boolean;
  begin
    Result := DirectoryExists(Path);
  end;

var
  Folder : string;
begin
  Folder := FInitialDir;
  if SelectDirectoryEx(Folder, FPromptText,
    '', BIF_RETURNONLYFSDIRS or $40, @CallBack, '') then
  begin
    FDirectory := Folder;
    Result := True;
  end;

  if (Length(FDirectory) = 0) then
  begin
    FDirectory := '';
    Result := False;
    Exit;
  end;

  if (Folder <> '') and (FDirectory[Length(FDirectory)] <> '\') then
  begin
    FDirectory := FDirectory + '\';
    Result := True
  end;
end;

end.

Przykładowy wygląd okna dialogowego:

Plik źródłowy modułu - skompresowany ZIP: browse.zip