browsedr.~pas

browsedr,一个自己编写的小控件,适合DELPHI5下用

  procedure CutFirstDirectory(var S: string);
  var
    Root: Boolean;
    P: Integer;
  begin
    if S = '\' then
      S := ''
    else begin
      if S[1] = '\' then begin
        Root := True;
        Delete(S, 1, 1);
      end else
        Root := False;
      if S[1] = '.' then
        Delete(S, 1, 4);
      P := Pos('\',S);
      if P <> 0 then begin
        Delete(S, 1, P);
        S := '...\' + S;
      end else
        S := '';
      if Root then
        S := '\' + S;
    end;
  end;

var
  Drive: string;
  Dir: string;
  Name: string;
  R: TRect;
  DC: HDC;
  MaxLen: integer;
  OldFont, Font: HFONT;
begin
  Result := FileName;
  if Wnd = 0 then exit;
  DC := GetDC(Wnd);
  if DC = 0 then exit;
  Font := HFONT(SendMessage(Wnd, WM_GETFONT, 0, 0));
  OldFont := SelectObject(DC, Font);
  try
    GetWindowRect(Wnd, R);
    MaxLen := R.Right - R.Left;

    Dir := ExtractFilePath(Result);
    Name := ExtractFileName(Result);

    if (Length(Dir) >= 2) and (Dir[2] = ':') then begin
      Drive := Copy(Dir, 1, 2);
      Delete(Dir, 1, 2);
    end else
      Drive := '';
    while ((Dir <> '') or (Drive <> '')) and (GetTextWidth(DC, Result) > MaxLen) do begin
      if Dir = '\...\' then begin
        Drive := '';
        Dir := '...\';
      end else if Dir = '' then
        Drive := ''
      else
        CutFirstDirectory(Dir);
      Result := Drive + Dir + Name;
    end;
  finally
    SelectObject(DC, OldFont);
    ReleaseDC(Wnd, DC);
  end;
end;

function MinimizeString(Wnd: HWND; const Text: string): string;
var
  R: TRect;
  DC: HDC;
  MaxLen: integer;
  OldFont, Font: HFONT;
  TempStr: string;
begin
  Result := Text;
  TempStr := Text;
  if Wnd = 0 then exit;
  DC := GetDC(Wnd);
  if DC = 0 then exit;
  Font := HFONT(SendMessage(Wnd, WM_GETFONT, 0, 0));
  OldFont := SelectObject(DC, Font);
  try
    GetWindowRect(Wnd, R);
    MaxLen := R.Right - R.Left;
    while (TempStr <> '') and (GetTextWidth(DC, Result) > MaxLen) do begin
      SetLength(TempStr, Length(TempStr)-1);
      Result := TempStr + '...';
    end;
  finally
    SelectObject(DC, OldFont);
    ReleaseDC(Wnd, DC);
  end;
end;


function DirExists(const Dir: string): boolean;
  function StripTrailingBackslash(const Dir: string): string;
  begin
    Result := Dir;
    // Make sure we have a string, and if so, see if the last char is a \
    if (Result <> '') and (Result[Length(Result)] = '\') then
      SetLength(Result, Length(Result)-1); // Shorten the length by one to remove
  end;
var
  Tmp: string;
  DriveBits: set of 0..25;
  SR: TSearchRec;
  Found: boolean;
  OldMode: Word;
begin
  OldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    if (Length(Dir) = 3) and (Dir[2] = ':') and (Dir[3] = '\') then begin
      Integer(DriveBits) := GetLogicalDrives;
      Tmp := UpperCase(Dir[1]);
      Result := (ord(Tmp[1]) - ord('A')) in DriveBits;
    end else begin
      Found := FindFirst(StripTrailingBackslash(Dir), faDirectory, SR) = 0;
      Result := Found and (Dir <> '');
      if Result then
        Result := (SR.Attr and faDirectory) = faDirectory;
      if Found then
        // only call FinClose if FindFirst succeeds.  Can lock NT up if it didn't
        FindClose(SR);
    end;
  finally
    SetErrorMode(OldMode);
  end;
end; // DirExists

function BrowseCallbackProc(Wnd: HWnd; Msg: UINT; lParam: LPARAM; lData: LPARAM): integer; stdcall;
var
  Cancel: boolean;
begin
  Result := 0;
  if lData <> 0 then
  begin
    case Msg of
      BFFM_INITIALIZED:
        TBrowseDirectoryDlg(lData).DoInitialized(Wnd);
      BFFM_SELCHANGED:
        TBrowseDirectoryDlg(lData).DoSelChanged(Wnd, PItemIDList(lParam));
      BFFM_VALIDATEFAILED:
        begin
          Cancel := FALSE;
          TBrowseDirectoryDlg(lData).DoValidateFailed(string(PChar(lParam)),
             Cancel);
          if Cancel then
            Result := 0
          else
            Result := 1;
        end;
    end;
  end;
end;


(*
function CopyPIDL(ShellMalloc: IMalloc; AnID: PItemIDList): PItemIDList;
var
  Size: integer;
begin
  Size := 0;
  if AnID <> NIL then
  begin
    while AnID.mkid.cb > 0 do
    begin
      Inc(Size, AnID.mkid.cb  + SizeOf(AnID.mkid.cb));
      AnID := PItemIDList(Longint(AnID) + AnID.mkid.cb);
    end;
  end;

  if Size > 0 then
  begin
    Result := ShellMalloc.Alloc(Size); // Create the memory
    FillChar(Result^, Size, #0); // Initialize the memory to zero
    Move(AnID^, Result^, Size); // Copy the current ID
  end else
    Result := NIL;
end;
*)

function GetImageIndex(const AFile: string): integer;
var
  SFI: TSHFileInfo;
begin
  SHGetFileInfo(PChar(AFile), 0, SFI, SizeOf(TSHFileInfo), SHGFI_SYSICONINDEX);
  Result := SFI.iIcon;
end;


function BrowseDirectory(const ShellMalloc: IMalloc; var Dest: string;
   var DestPIDL: PItemIDList; var ImgIdx: integer; var DisplayName: string;
   const AParent: TWinControl; const Title: string; Root: TRootID;
   Flags: TBrowseFlags; WantStatusText: boolean; Callback: TFNBFFCallBack;
   Data: Longint): boolean;
var
  shBuff: PChar;
  BrowseInfo: TBrowseInfo;
  idRoot, idBrowse: PItemIDList;
  WndHandle: HWND;
  OldErrorMode: word;
begin
  Result := FALSE; // Assume the worst.
  Dest := ''; // Clear it out.
  SetLength(Dest, MAX_PATH);  // Make sure their will be enough room in dest.
  if assigned(AParent) then
    WndHandle := AParent.Handle
  else
    WndHandle := 0;
  shBuff := PChar(ShellMalloc.Alloc(MAX_PATH)); // Shell allocate buffer.
  if assigned(shBuff) then begin
    try
      // Get id for desired root item.
      SHGetSpecialFolderLocation(WndHandle, ConvertRoot(Root), idRoot);
      try
        with BrowseInfo do begin  // Fill info structure
          hwndOwner := WndHandle;
          pidlRoot := idRoot;
          pszDisplayName := shBuff;
          lpszTitle := PChar(Title);
          ulFlags := ConvertFlags(Flags);
          { See if we need to handle the validate event }
          if bfEditBox in Flags then
            ulFlags := ulFlags or BIF_VALIDATE;
          if WantStatusText then
            ulFlags := ulFlags or BIF_STATUSTEXT;
          lpfn := Callback;
          lParam := Data;
        end;
        OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
        try
          idBrowse := SHBrowseForFolder(BrowseInfo);
        finally
          SetErrorMode(OldErrorMode);
        end;
        DestPIDL := idBrowse;
        if assigned(idBrowse) then begin
          // Try to turn it into a real path.
          if (bfComputers in Flags) then
          begin
            { Make a copy because SHGetPathFromIDList will whack it }
            Dest:= '\\' + string(shBuff);
            Result := SHGetPathFromIDList(idBrowse, shBuff);
            { Is it a valid path? }
            if Result then
              Dest := shBuff // Put it in user's variable.
            else
              { do nothing, the copy we made above is set to go };
            Result:= True;
          end else begin
            Result := SHGetPathFromIDList(idBrowse, shBuff);
            Dest := shBuff; // Put it in user's variable.
          end;
          // Stupid thing won't return the index if the user typed it in.
          if Result and (BrowseInfo.iImage = -1) then
            ImgIdx := GetImageIndex(Dest)
          else
            ImgIdx := BrowseInfo.iImage; // Update the image index.
        end;
        if not Result then
          Result := DestPIDL <> NIL;
        if Result then
          DisplayName := BrowseInfo.pszDisplayName;
      finally
        ShellMalloc.Free(idRoot); // Clean-up.
      end;
    finally
      ShellMalloc.Free(shBuff); // Clean-up.
    end;
  end;
end;

constructor TBrowseDirectoryDlg.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDisplayName := '';
  FDlgWnd := 0;
  FFitStatusText := TRUE;
  FEnableOKButton := TRUE;
  FTitle := '';
  FRoot := idDesktop;
  FOptions := [];
  FSelection := '';
  FSelectionPIDL := NIL;
  FCenter := TRUE;
  FSelChanged := NIL;
  FStatusText := '';
  FImageIndex := -1;
  FCaption := '';
  SHGetMalloc(FShellMalloc);

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

destructor TBrowseDirectoryDlg.Destroy;
begin
  if assigned(FSelectionPIDL) then
    FShellMalloc.Free(FSelectionPIDL);
  // D3 cleans it up for you, D2 does not.
  {$IFNDEF DFS_NO_COM_CLEANUP} FShellMalloc.Release; {$ENDIF}

  inherited Destroy;
end;