Главная » Delphi » Win API » Как вызвать стандартный диалог выбора директории с возможностью создания новой папки?

Как вызвать стандартный диалог выбора директории с возможностью создания новой папки?

15:59
uses
ShlObj;


function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData:
LPARAM): Integer; stdcall;
begin
if (uMsg = BFFM_INITIALIZED) then
SendMessage(hwnd, BFFM_SETSELECTION, 1, lpData);
BrowseCallbackProc := 0;
end;
 
 
function GetFolderDialog(Handle: Integer; Caption: string; var strFolder:
string): Boolean;
const
BIF_STATUSTEXT = $0004;
BIF_NEWDIALOGSTYLE = $0040;
BIF_RETURNONLYFSDIRS = $0080;
BIF_SHAREABLE = $0100;
BIF_USENEWUI = BIF_EDITBOX or BIF_NEWDIALOGSTYLE;
 
var
BrowseInfo: TBrowseInfo;
ItemIDList: PItemIDList;
JtemIDList: PItemIDList;
Path: PAnsiChar;
begin
Result := False;
Path := StrAlloc(MAX_PATH);
SHGetSpecialFolderLocation(Handle, CSIDL_DRIVES, JtemIDList);
with BrowseInfo do
begin
hwndOwner := GetActiveWindow;
pidlRoot := JtemIDList;
SHGetSpecialFolderLocation(hwndOwner, CSIDL_DRIVES, JtemIDList);
 
{ return display name of item selected }
pszDisplayName := StrAlloc(MAX_PATH);
 
{ set the title of dialog }
lpszTitle := PChar(Caption); //'Select the folder';
{ flags that control the return stuff }
ulFlags := ulFlags or BIF_NEWDIALOGSTYLE or BIF_RETURNONLYFSDIRS;
//ulFlags := ulFlags or BIF_RETURNONLYFSDIRS;
lpfn := @BrowseCallbackProc;
{ extra info that's passed back in callbacks }
lParam := LongInt(PChar(strFolder));
end;
 
ItemIDList := SHBrowseForFolder(BrowseInfo);
 
if (ItemIDList <> nil) then
if SHGetPathFromIDList(ItemIDList, Path) then
begin
strFolder := Path;
Result := True
end;
end;


procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
if GetFolderDialog(handle, 'Select folder', s) then showmessage(s);
end;