Delphi 弹出Windows风格的选择文件夹对话框，还可以新建文件夹

unit Unit2;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, FileCtrl, Buttons, shlobj,ActiveX;

type
TForm2 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
private
    { Private declarations }
public
    { Public declarations }
end;

var
Form2: TForm2;
Path: string;//起始路径

implementation

{$R *.dfm}

function BrowseProc(hWin:THandle; uMsg: Cardinal; lParam:LPARAM;lpData:LPARAM):LRESULT;stdcall;
begin
if uMsg   = BFFM_INITIALIZED   then
SendMessage(hWin,BFFM_SETSELECTION,1,lpData); //   用传过来的参数作默认路径
Result   :=   0;
end;

function aa: string;
var
bi:TBrowseInfo; //uses ShlObj
IdList,RootItemIDList:PItemIDList;
IDesktopFolder:IShellFolder;
Eaten,Flags:LongWord;
begin
    result:='';
    FillChar(bi,SizeOf(bi),0);
    bi.hwndOwner:=0;
    bi.lpszTitle:='';
    bi.ulFlags:= BIF_RETURNONLYFSDIRS+64;   //加了64，显示"新建文件夹"按钮
    bi.lpfn := @BrowseProc;
    bi.lParam:=0;
    IdList :=SHBrowseForFolder(bi);
    if IdList<>nil then
    begin
        SetLength(result,255);
        SHGetPathFromIDList(IdList,PChar(result));
        result:=string(pchar(result));
        if result<>'' then
          if result[Length(result)]<>'\' then
                result:=result+'\';
    end;
end;

procedure TForm2.Button1Click(Sender: TObject);
begin
ShowMessage(aa);
end;
//***************************第一种
//**************************第二种

function BrowseCallbackProc(hwnd: HWND;uMsg: UINT;lParam: Cardinal;lpData: Cardinal): integer; stdcall;
begin
if uMsg=BFFM_INITIALIZED then
result :=SendMessage(Hwnd,BFFM_SETSELECTION,Ord(TRUE),Longint(PChar(Path)))
else
result :=1
end;

function SelDir(const Caption: string; const Root: WideString; out Directory: string): Boolean;
var
WindowList: Pointer;
BrowseInfo: TBrowseInfo;
Buffer: PChar;
RootItemIDList, ItemIDList: PItemIDList;
ShellMalloc: IMalloc;
IDesktopFolder: IShellFolder;
Eaten, Flags: LongWord;
begin
Result := False;
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;
with BrowseInfo do begin
hwndOwner := Application.Handle;
pidlRoot := RootItemIDList;
pszDisplayName := Buffer;
lpszTitle := PChar(Caption);
ulFlags := BIF_RETURNONLYFSDIRS;
lpfn :=@BrowseCallbackProc;
lParam :=BFFM_INITIALIZED;
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;

procedure TForm2.Button2Click(Sender: TObject);
var
Path1: string;
begin
Path :=Edit1.Text;
SelDir('SelectDirectory Sample','',Path1);
Edit1.Text :=Path1
end;

end.

秒客网

Delphi 弹出Windows风格的选择文件夹对话框，还可以新建文件夹