browsedr.pas

动态提示控件

          AParent := TWinControl(Owner)
        else
          if assigned(Application) and assigned(Application.MainForm) then
            AParent := Application.MainForm;
    end;

  { Call the function }
  Result := BrowseDirectory(FShellMalloc, S, TempPIDL, FImageIndex,
     FDisplayName, AParent, FTitle, FRoot, FOptions,
     (FStatusText <> '') or FShowSelectionInStatus, BrowseCallbackProc,
     LongInt(Self));

  FDlgWnd := 0; { Not valid any more. }

  { If selection made, update property }
  if Result then
  begin
    FSelection := S;
    SelectionPIDL := TempPIDL;
  end else begin
    FSelection := '';
    SelectionPIDL := NIL;
  end;
end;

function FormatSelection(const APath: string): string;
begin
  Result := APath;
  if Result <> '' then begin
    if (Length(Result) < 4) and (Result[2] = ':') then begin
      if Length(Result) = 2 then
        Result := Result + '\'
    end else
      if (Result[Length(Result)] = '\') and (Result <> '\') then
        SetLength(Result, Length(Result)-1);
  end;
end;

procedure TdfsBrowseDirectoryDlg.SendSelectionMessage;
var
  TempSelectionPIDL: PItemIDList;
  ShellFolder: IShellFolder;
  OLEStr: array[0..MAX_PATH] of TOLEChar;
  Eaten: ULONG;
  Attr: ULONG;
  shBuff: PChar;
begin
  if (FSelection = '') and assigned(FSelectionPIDL) then
  begin
    shBuff := PChar(FShellMalloc.Alloc(MAX_PATH)); // Shell allocate buffer.
    try
      if SHGetPathFromIDList(FSelectionPIDL, shBuff) then
        FSelection := shBuff
      else
        FSelection := '';
    finally
      FShellMalloc.Free(shBuff); // Clean-up.
    end;
    SendMessage(FDlgWnd, BFFM_SETSELECTION, 0, LPARAM(FSelectionPIDL));
  end else begin
    if Copy(FSelection, 1, 2) = '\\' then // UNC name!
    begin
      if SHGetDesktopFolder(ShellFolder) = NO_ERROR then
      begin
        try
          if ShellFolder.ParseDisplayName(FDlgWnd, NIL,
             StringToWideChar(FSelection, OLEStr, MAX_PATH), Eaten,
             TempSelectionPIDL, Attr) = NO_ERROR then
          begin
            SelectionPIDL := TempSelectionPIDL;
            SendMessage(FDlgWnd, BFFM_SETSELECTION, 0, LPARAM(FSelectionPIDL));
          end;
        finally
          {$IFNDEF DFS_NO_COM_CLEANUP} ShellFolder.Release; {$ENDIF}
        end;
      end;
    end else begin { normal path }
      if SHGetDesktopFolder(ShellFolder) = NO_ERROR then
      begin
        try
          if ShellFolder.ParseDisplayName(FDlgWnd, NIL,
             StringToWideChar(FSelection, OLEStr, MAX_PATH), Eaten,
             TempSelectionPIDL, Attr) = NO_ERROR then
            SelectionPIDL := TempSelectionPIDL;
        finally
          {$IFNDEF DFS_NO_COM_CLEANUP} ShellFolder.Release; {$ENDIF}
        end;
        SendMessage(FDlgWnd, BFFM_SETSELECTION, 1,
           LPARAM(FormatSelection(FSelection)));
      end;
    end;
  end;
end;

procedure TdfsBrowseDirectoryDlg.DoInitialized(Wnd: HWND);
var
  Rect: TRect;
begin
  FDlgWnd := Wnd;
  if FCenter then begin
    GetWindowRect(Wnd, Rect);
    SetWindowPos(Wnd, 0,
      (GetSystemMetrics(SM_CXSCREEN) - Rect.Right + Rect.Left) div 2,
      (GetSystemMetrics(SM_CYSCREEN) - Rect.Bottom + Rect.Top) div 2,
      0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
  end;

if [bfNewDialogStyle, bfUseNewUI] * Options <> [] then
  ShowStatusTextLabel;

  // Documentation for BFFM_ENABLEOK is incorrect.  Value sent in LPARAM, not WPARAM.
  SendMessage(FDlgWnd, BFFM_ENABLEOK, 0, LPARAM(FEnableOKButton));
  if FStatusText <> '' then
    SendMessage(Wnd, BFFM_SETSTATUSTEXT, 0, LPARAM(PChar(FittedStatusText)));
  if (FSelection <> '') or (FSelectionPIDL <> NIL) then
    SendSelectionMessage;
  if FCaption <> '' then
    SendMessage(FDlgWnd, WM_SETTEXT, 0, LPARAM(FCaption));
  if assigned(FOnCreate) then
    FOnCreate(Self);
end;

procedure TdfsBrowseDirectoryDlg.DoSelChanged(Wnd: HWND; Item: PItemIDList);
var
  Name: string;
begin
  if FShowSelectionInStatus or assigned(FSelChanged) then
  begin
    Name := '';
    SetLength(Name, MAX_PATH);
    SHGetPathFromIDList(Item, PChar(Name));
    SetLength(Name, StrLen(PChar(Name)));
    if FShowSelectionInStatus then
      StatusText := Name;
    if assigned(FSelChanged) then
      FSelChanged(Self, Name, Item);
  end;
end;

procedure TdfsBrowseDirectoryDlg.DoValidateFailed(Path: string;
   var Cancel: boolean);
begin
  if assigned(FOnValidateFailed) then
    FOnValidateFailed(Self, Path, Cancel);
end;

procedure TdfsBrowseDirectoryDlg.SetFitStatusText(Val: boolean);
begin
  if FFitStatusText = Val then exit;
  FFitStatusText := Val;
  // Reset the status text area if needed.
  if FDlgWnd <> 0 then
    SendMessage(FDlgWnd, BFFM_SETSTATUSTEXT, 0, LPARAM(PChar(FittedStatusText)));
end;

procedure TdfsBrowseDirectoryDlg.SetStatusText(const Val: string);
begin
  if FStatusText = Val then exit;
  FStatusText := Val;
  if FDlgWnd <> 0 then
    SendMessage(FDlgWnd, BFFM_SETSTATUSTEXT, 0, LPARAM(PChar(FittedStatusText)));
end;

procedure TdfsBrowseDirectoryDlg.SetSelection(const Val: string);
begin
  if FSelection = Val then exit;
  FSelection := Val;
  // Add trailing backslash so it looks better in the IDE.
  if (FSelection <> '') and (FSelection[Length(FSelection)] <> '\') and
     DirExists(FSelection) then
    FSelection := FSelection + '\'
  else if (FSelection = '') and assigned(FSelectionPIDL) then
  begin
    FShellMalloc.Free(FSelectionPIDL);
    FSelectionPIDL := NIL;
  end;
  if FShowSelectionInStatus then
    StatusText := FSelection;
  if FDlgWnd <> 0 then
    SendSelectionMessage;
end;

procedure TdfsBrowseDirectoryDlg.SetSelectionPIDL(Value: PItemIDList);
begin
	if (FSelectionPIDL <> Value) then
  begin
    if assigned(FSelectionPIDL) then
      FShellMalloc.Free(FSelectionPIDL);
		FSelectionPIDL := Value;
	end;
end;



procedure TdfsBrowseDirectoryDlg.SetEnableOKButton(Val: boolean);
begin
  FEnableOKButton := Val;
  if FDlgWnd <> 0 then
    // Documentation for BFFM_ENABLEOK is incorrect.  Value sent in LPARAM, not WPARAM.
    SendMessage(FDlgWnd, BFFM_ENABLEOK, 0, LPARAM(FEnableOKButton));
end;

function TdfsBrowseDirectoryDlg.GetCaption: string;
var
  Temp: array[0..255] of char;
begin
  if FDlgWnd <> 0 then
  begin
    SendMessage(FDlgWnd, WM_GETTEXT, SizeOf(Temp), LPARAM(@Temp));
    Result := string(Temp);
  end else
    Result := FCaption;
end;

procedure TdfsBrowseDirectoryDlg.SetCaption(const Val: string);
begin
  FCaption := Val;
  if FDlgWnd <> 0 then
    SendMessage(FDlgWnd, WM_SETTEXT, 0, LPARAM(FCaption));
end;

procedure TdfsBrowseDirectoryDlg.SetParent(AParent: TWinControl);
begin
  FParent := AParent;
end;

// Note that BOOL <> boolean type.  Important!
function FindStatusTextWndProc(Child: HWND; Data: LParam): BOOL; stdcall;
const
  STATUS_TEXT_WINDOW_ID = 14147;
type
  PHWND = ^HWND;
begin
//  if GetWindowLong(Child, GWL_ID) = STATUS_TEXT_WINDOW_ID then begin
  if not IsWindowVisible(Child) then
  begin
ShowWindow(Child, SW_SHOW);
EnableWindow(Child, true);
SendMessage(Child, WM_SETTEXT, 0, LPARAM(PCHAR('foo'))); 
    PHWND(Data)^ := Child;
    Result := TRUE;
  end else
    Result := TRUE;
end;

procedure TdfsBrowseDirectoryDlg.ShowStatusTextLabel;
var
  ChildWnd: HWND;
begin
  if FDlgWnd <> 0 then
  begin
    ChildWnd := 0;
    if FDlgWnd <> 0 then
      // Enumerate all child windows of the dialog to find the status text window.
      EnumChildWindows(FDlgWnd, @FindStatusTextWndProc, LPARAM(@ChildWnd));

    if (ChildWnd <> 0) then
      ShowWindow(ChildWnd, SW_SHOW);
  end;
end;

// Note that BOOL <> boolean type.  Important!
function EnumChildWndProc(Child: HWND; Data: LParam): BOOL; stdcall;
const
  STATUS_TEXT_WINDOW_ID = 14147;
type
  PHWND = ^HWND;
begin
  if GetWindowLong(Child, GWL_ID) = STATUS_TEXT_WINDOW_ID then begin
    PHWND(Data)^ := Child;
    Result := FALSE;
  end else
    Result := TRUE;
end;

function TdfsBrowseDirectoryDlg.FittedStatusText: string;
var
  ChildWnd: HWND;
begin
  Result := FStatusText;
  if FFitStatusText then begin
    ChildWnd := 0;
    if FDlgWnd <> 0 then
      // Enumerate all child windows of the dialog to find the status text window.
      EnumChildWindows(FDlgWnd, @EnumChildWndProc, LPARAM(@ChildWnd));
    if (ChildWnd <> 0) and (FStatusText <> '') then
      if DirExists(FStatusText) then
        Result := MinimizeName(ChildWnd, FStatusText)
      else
        Result := MinimizeString(ChildWnd, FStatusText);
  end;
end;

function TdfsBrowseDirectoryDlg.GetDisplayName: string;
var
  ShellFolder: IShellFolder;
  Str : TStrRet;
begin
  Result := '';
  if FSelectionPIDL <> NIL then
  begin
    if SHGetDesktopFolder(ShellFolder) = NO_ERROR then
    begin
      try
        if ShellFolder.GetDisplayNameOf(FSelectionPIDL, SHGDN_FORPARSING,
           Str) = NOERROR then
        begin
          case Str.uType of
            STRRET_WSTR:   Result := WideCharToString(Str.pOleStr);
            {$IFDEF DFS_COMPILER_4_UP}
            STRRET_OFFSET: Result := PChar(LongWord(FSelectionPIDL) + Str.uOffset);
            {$ELSE}
            STRRET_OFFSET: Result := PChar(Longint(FSelectionPIDL) + Str.uOffset);
            {$ENDIF}
            STRRET_CSTR:   Result := Str.cStr;
          end;
        end;
      finally
        {$IFNDEF DFS_NO_COM_CLEANUP} ShellFolder.Release; {$ENDIF}
      end;
    end;
  end;
  if Result = '' then
    Result := FDisplayName;
  if Result = '' then
    Result := FSelection;
end;

function TdfsBrowseDirectoryDlg.GetVersion: string;
begin
  Result := DFS_COMPONENT_VERSION;
end;

procedure TdfsBrowseDirectoryDlg.SetVersion(const Val: string);
begin
  { empty write method, just needed to get it to show up in Object Inspector }
end;

procedure TdfsBrowseDirectoryDlg.SetOptions(const Val: TBrowseFlags);
begin
  if FOptions <> Val then
  begin
    FOptions := Val;
    if bfIncludeURLs in FOptions then
      FOptions := FOptions + [bfIncludeFiles, bfUseNewUI];
    if bfShareable in FOptions then
      FOptions := FOptions + [bfUseNewUI];
    if bfUseNewUI in FOptions then
      FOptions := FOptions + [bfNewDialogStyle, bfEditBox];
  end;
end;

end.