下面用于调用ShBrowseForFolder的包装器代码只能运行一次：如果我第二次调用Execute方法，则对话框不会出现在“PtrIDL：= ShBrowseForFolder（BrowseInfo）;”上。呼叫。任何人都可以看到什么是错的吗？
unit ShBrowseU;
(* Wrapper for ShBrowseForFolder
* 22/01/2004
*
* Changes JD 6-7-2012:
* - Inherit from TComponent
* - Published properties
* Changes JD 27-9-2012:
* - Coinitialize call only once
* Todo:
* - Make UNCFolder, FolderCheck, Options and SelIconIndex published properties
* - Catch Left/Top input < 0
* - Component needs icon
*)
interface
uses
Windows, Messages, SysUtils, Classes, Dialogs, ShlObj ;
type
TFolderCheck = function(Sender : TObject; Folder : string) : boolean of object;
TShBrowseOption = (sboBrowseForComputer, sboBrowseForPrinter,
sboBrowseIncludeFiles, sboBrowseIncludeURLs,
sboDontGoBelowDomain, sboEditBox, sboNewDialogStyle,
sboNoNewFolderButton, sboReturnFSAncestors,
sboReturnOnlyFSDirs, sboShareable, sboStatusText,
sboUAHint, sboUseNewUI, sboValidate);
TShBrowseOptions = set of TShBrowseOption;
TShBrowse = class(TComponent)
private
FBrowseWinHnd : THandle;
FCaption : string;
FFolder : string;
FFolderCheck : TFolderCheck;
FInitFolder : string;
FLeft : integer;
FOptions : TShBrowseOptions;
FSelIconIndex : integer;
FTop : integer;
FUserMessage : string;
WinFlags : DWord;
FCoInitialized: Boolean;
procedure Callback(Handle : THandle; MsgId : integer; lParam : DWord);
function GetUNCFolder : string;
function IdFromPIdL(PtrIdL : PItemIdList; FreeMem : boolean) : string;
procedure SetOptions(AValue : TShBrowseOptions);
protected
property BrowseWinHnd : THandle read FBrowseWinHnd write FBrowseWinHnd;
published
property Caption : string read FCaption write FCaption;
property InitFolder : string read FInitFolder write FInitFolder;
property Left : integer read FLeft write FLeft; // both Left & Top must be > 0 to position window
property Top : integer read FTop write FTop;
property UserMessage : string read FUserMessage write FUserMessage;
public
constructor Create(AOwner: TComponent); override;
function Execute : boolean;
property Folder : string read FFolder;
property UNCFolder : string read GetUNCFolder;
property FolderCheck : TFolderCheck write FFolderCheck;
property Options : TShBrowseOptions read FOptions write SetOptions;
property SelIconIndex : integer read FSelIconIndex;
end;
implementation
uses
ActiveX;
const
BIF_RETURNONLYFSDIRS = $00000001;
BIF_DONTGOBELOWDOMAIN = $00000002;
BIF_STATUSTEXT = $00000004;
BIF_RETURNFSANCESTORS = $00000008;
BIF_EDITBOX = $00000010;
BIF_VALIDATE = $00000020;
BIF_NEWDIALOGSTYLE = $00000040;
BIF_USENEWUI = $00000040;
BIF_BROWSEINCLUDEURLS = $00000080;
BIF_NONEWFOLDERBUTTON = 0;
BIF_UAHINT = 0;
BIF_BROWSEFORCOMPUTER = $00001000;
BIF_BROWSEFORPRINTER = $00002000;
BIF_BROWSEINCLUDEFILES = $00004000;
BIF_SHAREABLE = $00008000;
BFFM_VALIDATEFAILED = 3;
ShBrowseOptionArray : array[TShBrowseOption] of DWord =
(BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER,
BIF_BROWSEINCLUDEFILES, BIF_BROWSEINCLUDEURLS,
BIF_DONTGOBELOWDOMAIN, BIF_EDITBOX, BIF_NEWDIALOGSTYLE,
BIF_NONEWFOLDERBUTTON, BIF_RETURNFSANCESTORS,
BIF_RETURNONLYFSDIRS, BIF_SHAREABLE, BIF_STATUSTEXT,
BIF_UAHINT, BIF_USENEWUI, BIF_VALIDATE);
function ShBFFCallback(hWnd : THandle; uMsg : integer;
lParam, lpData : DWord) : integer; stdcall;
{connects the ShBFF callback general function to the
Delphi method which handles it}
begin
TShBrowse(lpData).Callback(hWnd, uMsg, lParam); // calls object's method
Result := 0;
end;
constructor TShBrowse.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Caption := 'Browse for folder'; // default
UserMessage := 'Select folder'; // default
end;
procedure TShBrowse.Callback(Handle : THandle; MsgId : integer; lParam : DWord);
{Delphi method which handles the ShBFF callback}
var
WorkArea, WindowSize : TRect;
BFFWidth, BFFHeight : integer;
SelOK : boolean;
begin
FBrowseWinHnd := Handle;
case MsgId of
BFFM_INITIALIZED :
begin
if (FLeft = 0) or (FTop = 0) then begin
{center the browse window on screen}
GetWindowRect(FBrowseWinHnd, WindowSize); // get ShBFF window size
with WindowSize do begin
BFFWidth := Right - Left;
BFFHeight := Bottom - Top;
end;
SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0); // get screen size
with WorkArea do begin // calculate ShBFF window position
FLeft := (Right - Left - BFFWidth) div 2;
FTop := (Bottom - Top - BFFHeight) div 2;
end;
end;
{set browse window position}
// SetWindowPos(FBrowseWinHnd, HWND_TOP, FLeft, FTop, 0, 0, SWP_NOSIZE);
SetWindowPos(FBrowseWinHnd, HWND_TOPMOST, FLeft, FTop, 0, 0, SWP_NOSIZE); // Always on top
if (FCaption <> '') then
{set Caption}
SendMessage(FBrowseWinHnd, WM_SETTEXT, 0, integer(PChar(FCaption)));
if (FInitFolder <> '') then
{set initial folder}
SendMessage(FBrowseWinHnd, BFFM_SETSELECTION, integer(LongBool(true)),
integer(PChar(FInitFolder)));
end;
BFFM_SELCHANGED :
begin
if Assigned(FFolderCheck) then
{get folder and check for validity}
if (lParam <> 0) then begin
FFolder := IdFromPIdL(PItemIdList(lParam), false);
{check folder ....}
SelOK := FFolderCheck(Self, FFolder);
{... en/disable OK button}
SendMessage(Handle, BFFM_ENABLEOK, 0, integer(SelOK));
end; {if (lParam <> nil)}
{end; if Assigned(FFolderCheck)}
end;
{ BFFM_IUNKNOWN :;
BFFM_VALIDATEFAILED :; }
end;
end;
procedure TShBrowse.SetOptions(AValue : TShBrowseOptions);
var
I : TShBrowseOption;
begin
if (AValue <> FOptions) then begin
FOptions := AValue;
WinFlags := 0;
for I := Low(TShBrowseOption) to High(TShBrowseOption) do
if I in AValue then
WinFlags := WinFlags or ShBrowseOptionArray[I];
end;
end;
function TShBrowse.Execute : boolean;
// Called to display the ShBFF window and return the selected folder
var
BrowseInfo : TBrowseInfo;
IconIndex : integer;
PtrIDL : PItemIdList; // Item identifier list
begin
FillChar(BrowseInfo, SizeOf(TBrowseInfo), #0);
IconIndex := 0;
with BrowseInfo do begin
hwndOwner := Self.FBrowseWinHnd;
PIDLRoot := nil;
pszDisplayName := nil;
lpszTitle := PChar(FUserMessage);
ulFlags := WinFlags;
lpfn := @ShBFFCallback;
lParam := integer(Self); // this object's reference
iImage := IconIndex;
end;
// if not FCoInitialized then FCoInitialized := Succeeded(CoInitializeEx(nil,COINIT_APARTMENTTHREADED));
PtrIDL := ShBrowseForFolder(BrowseInfo);
if PtrIDL = nil then
Result := false
else begin
FSelIconIndex := BrowseInfo.iImage;
FFolder := IdFromPIdL(PtrIDL, true); // This clears memory again
Result := true;
end; {if PtrIDL = nil else}
end;
function TShBrowse.IdFromPIdL(PtrIdL : PItemIdList; FreeMem : boolean) : string;
var
AMalloc : IMalloc;
begin
Result := '';
SetLength(Result, MAX_PATH);
SHGetPathFromIDList(PtrIDL, PChar(Result));
Result := trim(Result);
Result := string(PChar(Result));
// When a PIDL is passed via BFFM_SELCHANGED and that selection is OK'ed
// then the PIDL memory is the same as that returned by ShBrowseForFolder.
// This leads to the assumption that ShBFF frees the memory for the PIDL
// passed by BFFM_SELCHANGED if that selection is NOT OK'ed. Hence one
// should free memory ONLY when ShBFF returns, NOT for BFF_SELCHANGED
if FreeMem then begin
{free PIDL memory ...}
ShGetMalloc(AMalloc);
AMalloc.Free(PtrIDL);
end;
end;
function TShBrowse.GetUNCFolder : string;
function GetErrorStr(Error : integer) : string;
begin
Result := 'Unknown Error : ' + IntToStr(Error); // default
case Error of
ERROR_BAD_DEVICE : Result := 'Invalid path';
ERROR_CONNECTION_UNAVAIL : Result := 'No connection';
ERROR_EXTENDED_ERROR : Result := 'Network error';
ERROR_MORE_DATA : Result := 'Buffer too small';
ERROR_NOT_SUPPORTED : Result := 'UNC name not supported';
ERROR_NO_NET_OR_BAD_PATH : Result := 'Unrecognised path';
ERROR_NO_NETWORK : Result := 'Network unavailable';
ERROR_NOT_CONNECTED : Result := 'Not connected';
end;
end;
var
LenResult : Cardinal;
Error : integer;
PtrUNCInfo : PUniversalNameInfo;
begin
{note that both the PChar _and_ the characters it
points to are placed in UNCInfo by WNetGetUniversalName
on return, hence the extra allocation for PtrUNCInfo}
LenResult := 4 + MAX_PATH; // "4 +" for storage for lpUniversalName == @path
SetLength(Result, LenResult);
PtrUNCInfo := AllocMem(LenResult);
// bh, 13-8-2012, PAnsiChar replaced by PWideChar
Error := WNetGetUniversalName(PWideChar(FFolder), UNIVERSAL_NAME_INFO_LEVEL,
PtrUNCInfo, LenResult);
if Error = NO_ERROR then begin
Result := string(PtrUNCInfo^.lpUniversalName);
SetLength(Result, Length(Result));
end
else
Result := GetErrorStr(Error);
end;
end.
请注意，我注释掉了CoInitializeEx调用，但这没有任何区别。
这是XE2代码，Win7 64位下的Win32测试应用程序。
提前致谢 扬
答案 0 :(得分：4)
这里有很多奇怪的代码，但我不会试图深入。我会说虽然FBrowseWinHnd输入错误。它是HWND。你在这个单位里没有THandle个。它们都应该是HWND。
错误在于：
with BrowseInfo do begin
hwndOwner := Self.FBrowseWinHnd;//oops, this is wrong
将对话框的所有者窗口设置为窗口句柄，代表上次显示的对话框。这就是为什么它只在第二次询问时才会失败。
显然这是错的。只需删除此行代码并将hwndOwner保留为0.如果要将对话框设为所有者，请更改Execute的签名以接收所有者窗口句柄，然后将其传递给对话框
如何调试成功一次的API调用，然后再次调用失败？第一步是查看参数的值，看看它们是否因呼叫而异。事实上正是这样才是我发现问题的方法。