| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL | | Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

	« предыдущая ветвь | форум | следующая ветвь »

Диалог выбора директории [D2005, XP]

Steep ©   (2007-04-28 14:46:00) 

Как запустить выбор директори?
В винде помоему этот диалог стандартный..
Еще бывает "Простой" и с возможность создать папку
-как так сделать?

---

Loginov Dmitry   (2007-04-28 15:57:00) [1]

Переменную Index забыл удалить :(

---

Loginov Dmitry   (2007-04-28 15:55:00) [2]

Опередили :(
Но все же выложу:


 threadvar
   StoreBrowsePath: string;

 function SelectDirectoryEx(var APath: string; const Title: string = ''; CanCreateDir: Boolean = False): Boolean;

   function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData: LPARAM): Integer; stdcall;
   begin
     Result := 0;
     if uMsg = BFFM_INITIALIZED then
       SendMessage(hwnd, BFFM_SETSELECTION, 1, LongInt(PChar(StoreBrowsePath)))
   end;

 var
   ItemID: Pointer;
   BrowseInfo: TBrowseInfo;
   DisplayName, Path: array [0..MAX_PATH] of Char;
   Index: Integer;
 begin
   Result := False;

   {Запоменаем переданный путь, иначе callback-функция BrowseCallbackProc не сможет
    получить доступ к строке APath}
   StoreBrowsePath := APath;

   ZeroMemory(@BrowseInfo, SizeOf(BrowseInfo));

   BrowseInfo.hwndOwner := GetActiveWindow;
   BrowseInfo.pszDisplayName := @DisplayName;
   BrowseInfo.lpszTitle := PChar(Title);
   BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS or BIF_EDITBOX;
   if CanCreateDir then
     BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_NEWDIALOGSTYLE;
   BrowseInfo.lpfn:= @BrowseCallbackProc;

   ItemID:= SHBrowseForFolder(BrowseInfo);
   if ItemID <> nil then
   try
     SHGetPathFromIDList(ItemID, Path);
     if DirectoryExists(Path) then
     begin
       APath := Path;
       Result := True;
     end;
   finally
     GlobalFreePtr(ItemID);
   end;
 end;


Пример использования:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   APath: string;
 begin
   APath := Caption;
   if SelectDirectoryEx(APath, 'Выберите каталог с данными', True) then
     Caption := APath;
 end;


---

Steep   (2007-04-28 15:48:00) [3]

Спасибо всем!!!!!

---

Steep   (2007-04-28 15:36:00) [4]

Круто %)
Я почему его в делфи 2006 не встроили ....
Вроде столько способов вызвать :)

---

Германн   (2007-04-28 15:33:00) [5]

А чем SelectDirectory не угодил?

---

$00FF00   (2007-04-28 15:19:00) [6]

На самом деле вот так (жутковато канешна, зато прогу лишним кодом из импортируемых модулей не нагружает :) ) --

type
// Штоб ничо лишнего не подключать к проге

 ITEMID = record                                
   cb : Word;
   ID : array [0..0] of Byte;
 end;

 ITEMIDLIST = record
   mkid : ITEMID;
 end;
 PITEMIDLIST = ^ITEMIDLIST;

 BFF_CALLBACK = function(h_Wnd: THandle; _Msg: UINT; w_Param, l_Param: Integer): Integer; stdcall;

 BROWSEINFO = record
   hwndOwner : THandle;
   pidlRoot  : PITEMIDLIST;
   pszName   : PChar;
   lpszTitle : PChar;
   ulFlags   : UINT;
   lpfn      : BFF_CALLBACK;
   lParam    : Integer;
   iImage    : Integer;
 end;

const MAX_BUF = 4096; // За глаза хватит :)))

function GetDir(var lpbi: BROWSEINFO): PITEMIDLIST; stdcall; external 'Shell32.dll' name 'SHBrowseForFolderA';
function ExtractPath(pidl: PITEMIDLIST; pszPath: PChar): BOOL; stdcall; external 'Shell32.dll' name 'SHGetPathFromIDList';

...

function cbk(Wnd: THandle; uMsg: UINT; lParam, lpData: Integer): Integer stdcall;
begin
if (uMsg=1)and(lpData<>0) then // 1=BFFM_INITIALIZED
 SendMessage(Wnd, 1126, 1, lpData); // 1126=BFFM_SETSEL
end;

function ChangeFolder(Parent:THandle; var InitDir:string):boolean;
// ------------------- \\
function CheckIfFolder(path:string):boolean;
// ++++++
function intToBin(i:Integer):string;
var tmp:string;
begin
repeat
 tmp:=IntToStr(i mod 2);
 i:=i div 2;
 Result:=tmp+result;
until i<2;
 Result:=IntToStr(i mod 2)+Result;

repeat
 result:='0'+result;
until length(result)>=8;
end;
// ++++++
function rs(const P: PChar): string;
var
 i: Integer;
begin
 SetLength(Result, Length(P));
 for i:=Length(P) downto 1 do
 begin
   Result[Length(P)-i] := P[I];
 end;
end;
// ++++++
var
 i:Cardinal;
 s:string;
begin
i:=GetFileAttributes(PChar(path));
s:=rs(PChar(intToBin(i)));
if s[5]='1' then result:=true else result:=false;
end;
// ------------------- \\
function ExtractDir(const ptc:string):string;
begin
result:=ptc;
if GetFileAttributes(PChar(result))<>$FFFFFFFF then begin
 if not CheckIfFolder(ptc) then begin
   repeat
     Delete(result, length(result), 1);
   until result[Length(result)]='\';
   Delete(result, length(result), 1);
 end;
end;
end;
// ------------------- \\
var
 bi : BROWSEINFO;
 pid : PITEMIDLIST;
 pTmp : PChar;
 sTmp : string;
begin
 sTmp:=InitDir;
 FillChar(bi, SIZEOF(BROWSEINFO), 0);
 with bi do begin
   hwndOwner := Parent;
   pidlRoot  := nil;
   GetMem(pTmp, MAX_BUF);
   pszName   := pTmp;
   lpszTitle := 'Выберите папку:';
   ulFlags   := 1; // 1=BIF_RETURNONLYFSDIRS
   lpfn      := cbk;
   if sTmp<>'' then
     lParam  := longint(PChar(ExtractDir(sTmp))) else
     lParam  := 0;
   iImage    := 0;
 end;
 pid:=GetDir(bi);
 FreeMem(pTmp);
 if pid<>nil then begin
   GetMem(pTmp, MAX_BUF);
   ExtractPath(pid, pTmp);
   InitDir:=pTmp;
   ChangeFolder:=true;
   FreeMem(pTmp);
 end else ChangeFolder:=false;
end;

Это более развёрнутый ответ ;)

ЗЫ. Вызываем ф-цию ChangeFolder: Прописываем в первый параметр идентификатор окна HWND (если это форма, то её хэндл), а во вторую - строковую вару, в которой содержится исходный путь доступа (не обязательно, можно и пустую). В неё будет возвращаться выбранная пользователем папка.

---

clickmaker   (2007-04-28 15:08:00) [7]

SHBrowseForFolder()

---

Наверх