Показать диалог выбора директории с кнопкой для создания новой

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

{….}

uses

ShlObj, ActiveX;

{….}

{

This code shows the SelectDirectory dialog with additional expansions:

— an edit box, where the user can type the path name,

— also files can appear in the list,

— a button to create new directories.

Dieser Code zeigt den SelectDirectory-Dialog mit zusatzlichen Erweiterungen:

— eine Edit-Box, wo der Benutzer den Verzeichnisnamen eingeben kann,

— auch Dateien konnen in der Liste angezeigt werden,

— eine Schaltflache zum Erstellen neuer Verzeichnisse.

}

function AdvSelectDirectory(const Caption: string; const Root: WideString;

var Directory: string; EditBox: Boolean = False; ShowFiles: Boolean = False;

AllowCreateDirs: Boolean = True): Boolean;

// callback function that is called when the dialog has been initialized

//or a new directory has been selected

// Callback-Funktion, die aufgerufen wird, wenn der Dialog initialisiert oder

//ein neues Verzeichnis selektiert wurde

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));

// include the following comment into your code if you want to react on the

//event that is called when a new directory has been selected

// binde den folgenden Kommentar in deinen Code ein, wenn du auf das Ereignis

//reagieren willst, das aufgerufen wird, wenn ein neues Verzeichnis selektiert wurde

{BFFM_SELCHANGED:

begin

SHGetPathFromIDList(PItemIDList(lParam), @PathName);

// the directory «PathName» has been selected

// das Verzeichnis «PathName» wurde selektiert

end;}

end;

Result := 0;

end;

var

WindowList: Pointer;

BrowseInfo: TBrowseInfo;

Buffer: PChar;

RootItemIDList, ItemIDList: PItemIDList;

ShellMalloc: IMalloc;

IDesktopFolder: IShellFolder;

Eaten, Flags: LongWord;

const

// necessary for some of the additional expansions

// notwendig fur einige der zusatzlichen Erweiterungen

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);

// defines how the dialog will appear:

// legt fest, wie der Dialog erscheint:

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;

// Example:

procedure TForm1.Button1Click(Sender: TObject);

var

dir: string;

begin

AdvSelectDirectory(‘Caption’, ‘c:\’, dir, False, False, True);

Label1.Caption := dir;

end;

{/codecitation}

Добавить комментарий