2

下面用于调用 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 测试应用程序。

提前致谢

4

1 回答 1

4

这里有很多看起来很奇怪的代码，但我不会尝试深入。我会说 FBrowseWinHnd 输入错误。它是HWND。THandle您在本单元中没有任何s。他们都应该是HWND。

错误在这里：

with BrowseInfo do begin
  hwndOwner := Self.FBrowseWinHnd;//oops, this is wrong

该集合是对话框的所有者窗口，它是上次显示对话框时代表对话框的窗口句柄。这就是为什么它只在第二次询问时失败。

显然这是错误的。只需删除这行代码并将其保留hwndOwner为 0。如果要为对话框指定所有者，请更改签名Execute以接收所有者窗口句柄，然后将其传递给对话框。

如何调试一次成功，然后再次调用失败的 API 调用？第一步是查看参数的值，看看它们是否因一次调用而异。确实正是这样做是我发现问题的方式。

于 2012-09-27T13:25:01.020 回答