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

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.