源码如下，各位高手帮忙看看。
unit QSelectDirectoryDialog;
interface
uses
Windows, Messages, SysUtils, Classes, QDialogs,shlobj,ActiveX,Forms;
type
TSelectDirectoryDialog = class(tdialog)
private
FCaption: String;
FDirectory: String;
FRoot: WideString;
{ Private declarations }
function BrowseCallbackProc(Handle: HWND; uMsg: UINT; lParam: Cardinal;
lpData: Cardinal): integer; stdcall;
function SelectDirectoryEx(const Caption: string; const Root: WideString;
out Directory: string): Boolean;
procedure SetCaption(const Value: String);
procedure SetDirectory(const Value: String);
procedure SetRoot(const Value: WideString);
protected
{ Protected declarations }
public
{ Public declarations }
property Directory: String read FDirectory write SetDirectory;
function Execute: Boolean;override;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property Caption: String read FCaption write SetCaption;
property Root: WideString read FRoot write SetRoot;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TSelectDirectoryDialog]);
end;
{ TSelectDirectoryDialog }
procedure TSelectDirectoryDialog.SetCaption(const Value: String);
begin
FCaption := Value;
end;
procedure TSelectDirectoryDialog.SetDirectory(const Value: String);
begin
FDirectory := Value;
end;
procedure TSelectDirectoryDialog.SetRoot(const Value: WideString);
begin
FRoot := Value;
end;
function TSelectDirectoryDialog.BrowseCallbackProc(Handle: HWND;
uMsg: UINT; lParam, lpData: Cardinal): integer;
var
dirbuf: array[0..Max_Path-1] of Char;
begin
Result := 0;
if uMsg = BFFM_INITIALIZED then
begin
if GetCurrentDirectory(Max_path,@dirbuf) > 0 then
// WParam is TRUE since you are passing a path.
// It would be FALSE if you were passing a pidl.
SendMessage(Handle,BFFM_SETSELECTION,1,LongInt(@Dirbuf));
end
else if uMsg = BFFM_SELCHANGED then
begin
// Set the status window to the currently selected path.
if SHGetPathFromIDList(PItemIDList(lParam) ,@Dirbuf) then
SendMessage(Handle,BFFM_SETSTATUSTEXT,0,LongInt(@Dirbuf));
end;
end;
constructor TSelectDirectoryDialog.Create(AOwner: TComponent);
begin
inherited Create(Aowner);
end;
destructor TSelectDirectoryDialog.Destroy;
begin
inherited Destroy;
end;
function TSelectDirectoryDialog.SelectDirectoryEx(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+16 or BIF_RETURNONLYFSDIRS+64 or BIF_STATUSTEXT;//包含 BIF_STATUSTEXT
lpfn := @TSelectDirectoryDialog.BrowseCallbackProc; //回调函数
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;
function TSelectDirectoryDialog.Execute: Boolean;
var TempDirect: string;
begin
result:=SelectDirectoryEx(Caption,Root,TempDirect);
SetDirectory(TempDirect);
end;
end.
]我自己写了一个控件，安装后显示have registered， 但在控件面板上不显示，
]