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

← →
Steep © (2007-04-28 14:46) [0]

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

← →
clickmaker © (2007-04-28 15:08) [1]

SHBrowseForFolder()

← →
$00FF00 (2007-04-28 15:19) [2]

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

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 (если это форма, то её хэндл), а во вторую - строковую вару, в которой содержится исходный путь доступа (не обязательно, можно и пустую). В неё будет возвращаться выбранная пользователем папка.

← →
Германн © (2007-04-28 15:33) [3]

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

← →
Steep © (2007-04-28 15:36) [4]

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

← →
Steep © (2007-04-28 15:48) [5]

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

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

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;

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

Диалог выбора директории Найти похожие ветки