下面的例子是正确的，但是为什么在Callback里面，必须采用全局变量，只要采用局部变量就会出现错误？我始终无法理解，难道是内存分配的原因？只要在Callback里面分配内存，就会出现错误！不过那个Longint(pchar(path))可以用一个integer(pchar('D:\TEMP'))常量来代替，却又是正确的！真的很奇怪。我用HeapAlloc来分配内存也无法达到全局变量的效果。
unit Unit1;
interface
uses
shlobj,ActiveX;
var
Form1: TForm1;
Path: string; //起始路径
implementation
{$R *.DFM}
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 TForm1.SpeedButton1Click(Sender: TObject);
var
Path1: string;
begin
Path :=Edit1.Text;
SelDir('SelectDirectory Sample','d:\temp',Path1);
Edit1.Text :=Path1
end;
end.
2002.11.14:
今天终于解决了设置初始目录必须使用全局变量的问题！高兴哪！这样可以有一个极其好用的SelectDirectory函数了！可以指定Root目录，还可以设定初始化目录！！！！原来，在CallBack里面，那个lParam参数是可以传递数据的，而MSDN中说INIT消息的时候，lParam是0，是错误的，而且MSDN中关于wParam的说法是自相矛盾的！奇怪。
下面的函数可以指定初始化目录，只要在调用之前，赋值给Path参数即可。
uses ShlObj , ActiveX ;
{*****************************************************}
{ The SelectDirectoryEx function like SelectDirectory }
{ But you can specify the Init Dir }
{ hOwn:Parent Window Handle }
{ Path:In and Out,In-->Init Dir }
{ Caption:Hint text }
{ Root:Root Dir }
{ uFlag:Which Style you want to use,like }
{ BIF_RETURNONLYFSDIRS or BIF_VALIDATE }
{ Please see Win32SDK for more detial }
{*****************************************************}
function SelectDirectoryEx ( hOwn : HWND ; var Path : string ; Caption , Root : string ; uFlag : DWORD = $25 ): Boolean ;
const
BIF_NEWDIALOGSTYLE = $0040 ;
var
BrowseInfo : TBrowseInfo ;
Buffer : PChar ;
RootItemIDList , ItemIDList : PItemIDList ;
ShellMalloc : IMalloc ;
IDesktopFolder : IShellFolder ;
Dummy : LongWord ;
function BrowseCallbackProc ( hwnd : HWND ; uMsg : UINT ; lParam : Cardinal ; lpData : Cardinal ): integer ; stdcall ;
var
PathName : array [ 0 .. MAX_PATH ] of char ;
begin
case uMsg of
BFFM_INITIALIZED :
SendMessage ( Hwnd , BFFM_SETSELECTION , Ord ( True ), Integer ( lpData ));
BFFM_SELCHANGED :
begin
SHGetPathFromIDList ( PItemIDList ( lParam ), @ PathName );
SendMessage ( hwnd , BFFM_SETSTATUSTEXT , 0 , LongInt ( PChar (@ PathName )));
end ;
end ;
Result := 0 ;
end ;
begin
Result := False ;
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 ( hOwn , nil , POleStr ( WideString ( Root )), Dummy , RootItemIDList , Dummy );
end ;
with BrowseInfo do begin
hwndOwner := hOwn ;
pidlRoot := RootItemIDList ;
pszDisplayName := Buffer ;
lpszTitle := PChar ( Caption );
ulFlags := uFlag ;
lpfn := @ BrowseCallbackProc ;
lParam := Integer ( Pchar ( Path ));
end ;
ItemIDList := ShBrowseForFolder ( BrowseInfo );
Result := ItemIDList <> nil ;
if Result then
begin
ShGetPathFromIDList ( ItemIDList , Buffer );
ShellMalloc . Free ( ItemIDList );
Path := StrPas ( Buffer );
end ;
finally
ShellMalloc . Free ( Buffer );
end ;
end ;
end ;
procedure TForm1 . SpeedButton1Click ( Sender : TObject );
var
Path : string ;
begin
Path := 'C:\WinNT' ;
if SelectDirectoryEx ( Handle , Path , 'Select Directory Sample' , 'C:\' ) then
ShowMessage ( Path );
end ;
*************************
function SelectDirectoryEx(const Caption: string; const Root: string;
out Directory: string; AX, AY: Integer): Boolean;
implementation
uses Math, ShlObj, ActiveX;
function SelectDirectoryEx(const Caption: string; const Root: string;
out Directory: string; AX, AY: Integer): Boolean;
type
PBFFRecord = ^TBFFRecord;
TBFFRecord = record
InitDir: PChar;
X: Integer;
Y: Integer;
end;
var
BFFR:TBFFRecord;
IDList: PItemIDList;
BrowseInfo: TBrowseInfo;
Malloc:IMalloc;
WindowList: Pointer;
Buffer: PChar;
function BrowseFolderProc(hWindow: HWND; uMsg: UINT; lParam: LPARAM;
lpData: LPARAM): Integer; stdcall;
var
PathName: array[0..MAX_PATH] of Char;
PBFFR:PBFFRecord;
r: TRect;
x, y, cx, cy, w, h: Integer;
begin
case uMsg of
BFFM_INITIALIZED:
begin
PBFFR := Pointer(lpData);
if lstrlen(PBFFR^.InitDir) > 1 then
SendMessage(hWindow,BFFM_SETSELECTION, 1, Integer(PBFFR^.InitDir));
cx := GetSystemMetrics(SM_CXSCREEN);
cy := GetSystemMetrics(SM_CYSCREEN);
GetWindowRect(hWindow, r);
w := r.Right - r.Left;
h := r.Bottom - r.Top;
x := PBFFR^.X;
y := PBFFR^.Y;
if (x = 0) or (y = 0) then
begin
x := (cx - w) div 2;
y := (cy - h) div 2;
end;
x := Max(Min(x, cx - w), 0);
y := Max(Min(y, cy - h), 0);
SetWindowPos(hWindow, 0, x, y, 0, 0, SWP_NOSIZE or SWP_NOZORDER);
end;
BFFM_SELCHANGED:
begin
SHGetPathFromIDList(PItemIDList(lParam), @PathName);
SendMessage(hWindow, BFFM_SETSTATUSTEXT, 0, LongInt(PChar(@PathName)));
end;
end;
Result := 0;
end;
begin
Result := False;
Directory := '';
BFFR.InitDir := PChar(Root);
BFFR.X := AX;
BFFR.Y := AY;
FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
if (ShGetMalloc(Malloc) = S_OK) and (Malloc <> nil) then
begin
Buffer := Malloc.Alloc(MAX_PATH);
try
with BrowseInfo do
begin
hwndOwner := Application.Handle;
pidlRoot := nil;
pszDisplayName := Buffer;
lpszTitle := PChar(Caption);
ulFlags := BIF_STATUSTEXT or BIF_RETURNONLYFSDIRS;
lpfn := @BrowseFolderProc;
lParam := Integer(@BFFR);
end;
WindowList := DisableTaskWindows(0);
try
IDList := ShBrowseForFolder(BrowseInfo);
finally
EnableTaskWindows(WindowList);
end;
Result := IDList <> nil;
if Result then
begin
ShGetPathFromIDList(IDList, Buffer);
Malloc.Free(IDList);
Directory := Buffer;
end;
finally
Malloc.Free(Buffer);
end;
end;
end;
---------------------------------------
{******************************************************************}
{
Heres an example on how to locate a folder with a specific filer,
using SHBrowseForFolder and a BrowseCallBack function
( by Jack Kallestrup )
}
uses ShlObj, ShellApi;
function BrowseCallBack ( Hwnd : THandle; uMsg : UINT; lpParam, lpData : LPARAM): integer; stdcall;
var
Buffer : Array[0..255] of char;
Buffer2 : Array[0..255] of char;
TmpStr : String;
begin
// Initialize buffers
FillChar(Buffer,SizeOf(Buffer),#0);
FillChar(Buffer2,SizeOf(Buffer2),#0);
// Statusline text
TmpStr := 'Locate folder containing '+StrPas(PChar(lpData));
// Copy statustext to pchar
StrPCopy(Buffer2,TmpStr);
// Send message to BrowseForDlg that
// the status text has changed
SendMessage(hwnd,BFFM_SETSTATUSTEXT,0,Integer(@Buffer2));
// If directory in BrowswForDlg has changed ?
if uMsg = BFFM_SELCHANGED then begin
// Get the new folder name
SHGetPathFromIDList(PItemIDList(lpParam),Buffer);
// And check for existens of our file.
{$IFDEF RX_D3} //RxLib - extentions
if FileExists(NormalDir(StrPas(Buffer))+StrPas(PChar(lpData)))
and (StrLen(Buffer) > 0) then
{$ELSE}
if Length(StrPas(Buffer)) <> 0 then
if Buffer[Length(StrPas(Buffer))-1] = '\' then
Buffer[Length(StrPas(Buffer))-1] := #0;
if FileExists(StrPas(Buffer)+'\'+StrPas(PChar(lpData))) and
(StrLen(Buffer) > 0) then
{$ENDIF}
// found : Send message to enable OK-button
SendMessage(hwnd,BFFM_ENABLEOK,1,1)
else
// Send message to disable OK-Button
SendMessage(Hwnd,BFFM_ENABLEOK,0,0);
end;
result := 0
end;
function BrowseforFile(Handle : THandle; Title : String; Filename : String) : String;
var
BrowseInfo : TBrowseInfo;
RetBuffer,
FName,
ResultBuffer : Array[0..255] of char;
PIDL : PItemIDList;
begin
StrPCopy(Fname,FileName);
//Initialize buffers
FillChar(BrowseInfo,SizeOf(TBrowseInfo),#0);
Fillchar(RetBuffer,SizeOf(RetBuffer),#0);
FillChar(ResultBuffer,SizeOf(ResultBuffer),#0);
BrowseInfo.hwndOwner := Handle;
BrowseInfo.pszDisplayName := @Retbuffer;
BrowseInfo.lpszTitle := @Title[1];
// we want a status-text
BrowseInfo.ulFlags := BIF_StatusText;
// Our call-back function cheching for fileexist
BrowseInfo.lpfn := @BrowseCallBack;
BrowseInfo.lParam := Integer(@FName);
// Show BrowseForDlg
PIDL := SHBrowseForFolder(BrowseInfo);
// Return fullpath to file
if SHGetPathFromIDList(PIDL,ResultBuffer) then
result := StrPas(ResultBuffer)
else
Result := '';
GlobalFreePtr(PIDL); //Clean up
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
const
FileName = 'File.xyz';
var
Answer: Integer;
begin
if MessageBox(0, 'To locate the file yourself, click ok',
PChar(Format('File %s not found.',[FileName])),MB_OKCANCEL) = 1 then
BrowseforFile(Handle, 'locate ' + FileName, FileName);
end;