Developing.ru

Какой функцией (или компонентом) вызывается диологовое окно выбора папки. Можно ли как то настроить Topendialog на показ папок?
Заранее благодарен

Код: Выделить всё

unit BrowseForFolderU;

interface

function BrowseForFolder(const browseTitle: String; const initialFolder: String = ''): String;

implementation
uses Windows, shlobj, Forms;
var
  lg_StartFolder: String;

function BrowseForFolderCallBack(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;
begin
  if uMsg = BFFM_INITIALIZED then SendMessage(Wnd,BFFM_SETSELECTION,1,Integer(@lg_StartFolder[1]));
  result := 0;
end;

function BrowseForFolder(const browseTitle: String; const initialFolder: String =''): String;
const
  BIF_NEWDIALOGSTYLE    = $0040;
var
  browse_info: TBrowseInfo;
  folder: array[0..MAX_PATH] of char;
  find_context: PItemIDList;
begin
  FillChar(browse_info,SizeOf(browse_info),#0);
  lg_StartFolder := initialFolder;
  browse_info.pszDisplayName := @folder[0];
  browse_info.lpszTitle := PChar(browseTitle);
  browse_info.ulFlags := BIF_RETURNONLYFSDIRS or BIF_NEWDIALOGSTYLE;
  browse_info.hwndOwner:=Application.Handle;
  if initialFolder <> '' then browse_info.lpfn := BrowseForFolderCallBack;
  find_context := SHBrowseForFolder(browse_info);
  if Assigned(find_context) then
  begin
    if SHGetPathFromIDList(find_context,folder) then result := folder else result := '';
    GlobalFreePtr(find_context);
  end else result := '';
end;

end.

Код: Выделить всё

implementation
uses BrowseForFolderU;
{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  NewBaseDir:string;
begin
  NewBaseDir:=BrowseForFolder('Выбор папки сохранения персонажей',Edit1.Text);
  If NewBaseDir<>'' then
    begin
      If NewBaseDir[Length(NewBaseDir)]<>'\' then NewBaseDir:=NewBaseDir+'\';
      Edit1.Text:=NewBaseDir;
    end
end;

end.

Код: Выделить всё

Uses
  FileCtrl;

.....
  if SelectDirectory('Выберите папку','rfDesktop',Path) then
    begin
      eRoot.Text := Path;
      PluginsPath := Path;
    end;
.....

Второй параметр - начальная папка по-умолчанию, 3-й - переменная, куда возвращается результат

Еще один вариант:

Код: Выделить всё

function SelectFolder: String;
var
  TitleName: String;
  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 := MainFm.Handle;
  BrowseInfo.pszDisplayName := @DisplayName;
  TitleName := 'Выберите каталог:';
  BrowseInfo.lpszTitle := PChar(TitleName);
  BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
  lpItemID := SHBrowseForFolder(BrowseInfo);
  if lpItemId <> nil then
    begin
      SHGetPathFromIDList(lpItemID,TempPath);
      Result := TempPath;
      GlobalFreePtr(lpItemID);
    end;
end;

Большое спасибо. А теперь ещё один вопрос: как узнать содержимое папки (filename файлов)?

набираешь FindFirst, нажимешь Ctrl+F1, получешь Delphi example:

Код: Выделить всё

procedure TForm1.Button1Click(Sender: TObject);

var
  sr: TSearchRec;
  FileAttrs: Integer;
begin
  StringGrid1.RowCount := 1;
  if CheckBox1.Checked then
    FileAttrs := faReadOnly
  else
    FileAttrs := 0;
  if CheckBox2.Checked then
    FileAttrs := FileAttrs + faHidden;
  if CheckBox3.Checked then
    FileAttrs := FileAttrs + faSysFile;
  if CheckBox4.Checked then
    FileAttrs := FileAttrs + faVolumeID;
  if CheckBox5.Checked then

    FileAttrs := FileAttrs + faDirectory;
  if CheckBox6.Checked then
    FileAttrs := FileAttrs + faArchive;
  if CheckBox7.Checked then

    FileAttrs := FileAttrs + faAnyFile;

  with StringGrid1 do
  begin
    RowCount := 0;

    if FindFirst(Edit1.Text, FileAttrs, sr) = 0 then

    begin
      repeat
        if (sr.Attr and FileAttrs) = sr.Attr then
        begin
        RowCount := RowCount + 1;
        Cells[1,RowCount-1] := sr.Name;
        Cells[2,RowCount-1] := IntToStr(sr.Size);
        end;
      until FindNext(sr) <> 0;
      FindClose(sr);
    end;
  end;
end;

Эммм.....а как узнать, какие файлы находятся в папке?
Было бы неплохо, чтобы выдавался строковой массив всех файлов

Код: Выделить всё

Uses
  Classes, SysUtils;

function DirListing (const DirName: String): TStrings;
var
  SR: TSearchRec;
begin
  Result := nil;
  if not DirectoryExists(DirName) then
    exit;
  Result := TStringList.Create;
  if FindFirst(IncludeTrailingPathDelimiter(DirName)+'*.*',faAnyFile,SR)<>0 then
    exit;
  Result.Add(SR.Name);
  while FindNext(SR)=0 do
    Result.Add(SR.Name);
  FindClose(SR);
end;

Функция получения листинга папки. Для определения типа каждого элемента (файл или каталог) можно воспользоваться следующим условием:

Код: Выделить всё

.....
if ((SR.Attr and faDirectory)=faDirectory) then
//это папка
else
//это файл
.....

Если нужно возвращать именно массив строк, то можно так:

Код: Выделить всё

Uses
  SysUtils;

type
  tStrArr = array of String;

function DirListing (const DirName: String): tStrArr;
var
  SR: TSearchRec;
begin
  SetLength (Result,0);
  if not DirectoryExists(DirName) then
    exit;
  if FindFirst(IncludeTrailingPathDelimiter(DirName)+'*.*',faAnyFile,SR)<>0 then
    exit;
  SetLength (Result,1);
  Result[0] := SR.Name;
  while FindNext(SR)=0 do
    begin
      SetLength(Result,Length(Result)+1);
      Result[Length(Result)-1] := SR.Name;
    end;
  FindClose(SR);
end;