Shortening the pathname with an ellipses (...)

I found this function somewhere that I find very useful sometimes. Pass a long pathname to the function and a handle to the control the path is to be viewed in and it will return the shortened version with an ellipses (...). The control's handle is used to determine the width needed for the pathname and will work on any size the system's font settings are set to. For example, put a TPanel on a form, call the function like this: Panel1.Caption := MinimizePathName(Panel1.Handle, 'C:\This Directory\This Subdirectory\Another\ThisFile.txt'); and what you will see is 'C:\...\Another\ThisFile.txt'.

function MinimizePathName(Wnd: HWND; const Filename: string): string;
{ func to shorten the long path name with an ellipses '...' to fit }
{ in whatever control is passed to the Wnd parameter. }
{ Usage: Panel1.Caption := MinimizePathName(Panel1.Handle, DirectoryOutline1.Directory) }
{ This will shorten the path if necessary to fit in Panel1. }

  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;

  function GetTextWidth(DC: HDC; const Text: string): Integer;
  var
    Extent: TSize;
  begin
    if GetTextExtentPoint(DC, PChar(Text), Length(Text), Extent) then 
      Result := Extent.cX
    else 
      Result := 0;
  end;

var
  Drive,
  Dir,
  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;


Blue Orb Software
[email protected]