Диалог открытия директории

[Altera]

Как мне программно показать вот такой диалог, мне надо получить путь к директории а tDopenDlialog для этой цели помойму не очень подходит

[Stilet]

Unit

FileCtrl

Category

dialog and message routines

function SelectDirectory(const Caption: string; const Root: WideString; out Directory: string): Boolean; overload;
function SelectDirectory(var Directory: string; Options: TSelectDirOpts; HelpCtx: Longint): Boolean; overload;

Так подойдет?

[EdNovice]

function SelectDirectory(AOwner : HWnd) : string;
var
lpItemID : PItemIDList;
BrowseInfo : TBrowseInfo;
DisplayName : array[0..MAX_PATH] of Char;
TempPath : array[0..MAX_PATH] of Char;
begin
FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
BrowseInfo.hwndOwner := AOwner;
BrowseInfo.pszDisplayName := @DisplayName;
BrowseInfo.lpszTitle := 'Specify a directory';
BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
lpItemID := SHBrowseForFolder(BrowseInfo);
if Assigned(lpItemId) then
begin
SHGetPathFromIDList(lpItemID, TempPath);
GlobalFreePtr(lpItemID);
end
else Result := '';
Result := string(TempPath);
end;

[FaTaL]

Сама функция:

function AdvSelectDirectory(const Caption: string; const Root: WideString;
  var Directory: string; EditBox: Boolean = False; ShowFiles: Boolean = False;
  AllowCreateDirs: Boolean = True): Boolean;
  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));
    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;

А вот так её вызвать:

procedure Form1.Button1Click(Sender: TObject);
var
dir:string;
begin
AdvSelectDirectory('Выберите папку', 'd:\,c:\', dir, False, False, True);
end;

[zetrix]

Вы чего человека таким листингом пугаете?))

Правильно Stilet писал. Вот пример:

procedure TForm1.Button1Click(Sender: TObject);
var s:widestring;
begin
if SelectDirectory('Выберите директорю','',s) then form1.Caption:=s;
end;

P.S.: В uses надо добавить QDialogs!

______________________
Можно и FileCtrl...

таскать за собой еще и qtinf.dll

Будем знать. Спасибо.

[Stilet]

P.S.: В uses надо добавить QDialogs!

Неправильно, а точнее некоректно. Еще раз внимательно прочитай мой пост

[_Engine_]

Если добавить QDialogs, а не Dialogs, то придется таскать за собой еще и qtinf.dll

[Карась]

Мне кажется, что Stilet сообщает нам, что есть другая функция с такимже названием и если их перегрузить, то компилятор вызовет нужную.....

[Stilet]

Карась

Нет. Я говорю что Зетрикс немного ошибся указав на QDialogs, ибо эта функция есть в FileCtrl (Внимательно см. мой пост). Ато дийсно таскать много придется.

[mutabor]

FaTaL, а что это за страшная функция? В нее случайно кнопочки/галочки свои нельзя добавить?