www.pudn.com > yrsCapture.zip > SelFolder.pas

{******************************************************************************} 
{*                                                                            *} 
{*             Adirondack Software & Graphics Select Folder Unit              *} 
{*            (C) Copyright Adirondack Software & Graphics 1997               *} 
{*                                                                            *} 
{******************************************************************************} 
 
unit SelFolder; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  StdCtrls, Grids, Outline, DirOutln, ExtCtrls, ComCtrls, xShlTree; 
 
type 
  TSelectFolder = class(TForm) 
    Panel1: TPanel; 
    Label1: TLabel; 
    Button1: TButton; 
    Button2: TButton; 
    xShellTreeView1: TxShellTreeView; 
    procedure Button1Click(Sender: TObject); 
    procedure xShellTreeView1Change(Sender: TObject; Node: TTreeNode); 
  private 
    { Private declarations } 
    function EllipsifyText(AsPath: boolean; const Text: string; 
                       const Canvas: TCanvas; MaxWidth: integer): string; 
  public 
    { Public declarations } 
    SelectedFolder: String; 
  end; 
 
var 
  SelectFolder: TSelectFolder; 
 
implementation 
 
{$R *.DFM} 
 
{==============================================================================} 
function TSelectFolder.EllipsifyText(AsPath: boolean; const Text: string; 
                       const Canvas: TCanvas; MaxWidth: integer): string; 
{==============================================================================} 
 
  procedure CutFirstDirectory(var S: string); 
  var 
    Root: Boolean; 
    P: Integer; 
  begin 
    if S = '' then exit; 
    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; 
 
function MinimizeName(const Filename: string; const Canvas: TCanvas; 
                        MaxLen: Integer): string; 
  var 
    Drive: String; 
    Dir: String; 
    Name: String; 
  begin 
    Result := FileName; 
    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 (Canvas.TextWidth(Result) > MaxLen) do begin 
      if Dir = '\...\' then begin 
        Drive := ''; 
        Dir := '...\'; 
      end else if Dir = '' then 
        Drive := '' 
      else 
        CutFirstDirectory(Dir); 
      Result := Drive + Dir + Name; 
    end; 
  end; 
 
{$IFNDEF WIN32} 
  procedure SetLength(var s: string; NewLen: byte); 
  begin 
    S[0] := chr(NewLen); 
  end; 
{$ENDIF} 
 
var 
  Temp: String; 
  AvgChar: integer; 
  TLen, 
  Index: integer; 
  Metrics: TTextMetric; 
begin 
  try 
    if AsPath then begin 
      Result := MinimizeName(Text, Canvas, MaxWidth); 
    end else begin 
      Temp := Text; 
      if (Temp <> '') and (Canvas.TextWidth(Temp) > MaxWidth) then begin 
        GetTextMetrics(Canvas.Handle, Metrics); 
        AvgChar := Metrics.tmAveCharWidth; 
        if (AvgChar * 3) < MaxWidth then begin 
          Index := (MaxWidth div AvgChar) - 1; 
          Temp := Copy(Text, 1, Index); 
          if Canvas.TextWidth(Temp + '...') > MaxWidth then begin 
            repeat 
              dec(Index); 
              SetLength(Temp, Index); 
            until (Canvas.TextWidth(Temp + '...') < MaxWidth) or (Index < 1); 
            { delete chars } 
          end else begin 
            TLen := Length(Text); 
            repeat 
              inc(Index); 
              Temp := Copy(Text, 1, Index); 
            until (Canvas.TextWidth(Temp + '...') > MaxWidth) or (Index >= TLen); 
            SetLength(Temp, Index-1); 
          end; 
          Temp := Temp + '...'; 
        end else 
          Temp := '.'; 
      end; 
      Result := Temp; 
    end; 
  except 
    Result := ''; 
  end; 
end; 
procedure TSelectFolder.Button1Click(Sender: TObject); 
begin 
    SelectedFolder := LowerCase(xShellTreeView1.Directory); 
end; 
 
 
procedure TSelectFolder.xShellTreeView1Change(Sender: TObject; 
  Node: TTreeNode); 
begin 
  Label1.Caption := LowerCase(EllipsifyText(True, 
    xShellTreeView1.Directory, Canvas, 240)); 
end; 
 
end.