How do I shorten a path name

Hi mdlittle

Mabey you can try this

This function, when passed a long path name, will convert it to a short Win3.1 style path name.  For example: ExtractShortPathName('C:\This is a directory\This is a file.txt') will return 'C:\Thisis~1\Thisis~1.txt'.  To extract the long path name, see ExtractLongPathName().

function ExtractShortPathName(const FileName: string): string;
{ func to shorten the long path name to look like Win 3.1 naming conventions. }
{ If file doesn't exist, func will return an emtpy string.                    }
var
  Buffer: array[0..MAX_PATH] of Char;
begin
  SetString(Result, Buffer,
    GetShortPathName(PChar(FileName), Buffer, SizeOf(Buffer)));
end;

Regards

Zip58

Hi mdlittle!

Looks like you are searching for a function like MinimizeName()?

{ uses FileCtrl }

procedure TForm1.Button1Click(Sender: TObject);
var
  s: String;
begin
  s := 'c:\program files\directory1\directory2\directory3\file.name';
  Label1.Caption := MinimizeName(s, Label1.Canvas, Label1.Width);
end;

Markus

Hi mdlittle

Take also a look to this

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;

Ps.( not tested)

Regards

Zip58

var
  ii : integer;
  count : integer;
  start,stop : integer;
begin
  count := 0;
  start := 0;
  stop := 0;
  for ii := 1 to length(fPath) do begin
    // look for all the separators
    if fPath[ii] = '\'  then begin
      count := count + 1;  // count them
      if count = 2 then start := ii + 1  // 2nd is start
      else stop := ii;
    end;
  end;
  if (count > 2) and (stop > (start + 2)) then begin
    // we had at least 3 separators and can shorten
    fPath[start] := '.';
    fPath[start+1] := '.';
    fPath[start+2] := '.';
    start := start + 3;  // elipses
    for ii := stop to length(fPath) do begin
      // copy the last separator and the filename
      fPath[start] := fPath[ii];
      start := start + 1;
    end;
    setLength(fPath,start-1);  // shorten the string
  end;
end;
   

jbshumate:

Not sure how this works. I tried it and the string is truncated.

Meikl, what about using TStrings instead of TStringList (-> speed increase!)?

Markus

How did you use the code.  If you just typed it in as I gave it the compiler probably eliminated the final result since it was not used.  Here it is wrapped as a procedure and should work if you just cut and paste.


procedure Shorten(var fPath : string);
var
 ii : integer;
 count : integer;
 startPos,stop : integer;
begin
 count := 0;
 startPos := 0;
 stop := 0;
 for ii := 1 to length(fPath) do begin
   // look for all the separators
   if fPath[ii] = '\'  then begin
     count := count + 1;  // count them
     if count = 2 then startPos := ii + 1  // 2nd is start
     else stop := ii;
   end;
 end;
 if (count > 2) and (stop > (startPos + 2)) then begin
   // we had at least 3 separators and can shorten
   fPath[startPos] := '.';
   fPath[startPos+1] := '.';
   fPath[startPos+2] := '.';
   startPos := startPos + 3;  // elipses
   for ii := stop to length(fPath) do begin
     // copy the last separator and the filename
     fPath[startPos] := fPath[ii];
     startPos := startPos + 1;
   end;
   setLength(fPath,startPos - 1);  // shorten the string
 end;
end;

markus,

>what about using TStrings instead of TStringList
>(-> speed increase!)?

tsrings is a abstract class,
some methods are only abstract declared,
and must be implemented in a derived class
-> thats why i use tstringslist

it may be, that the methods i used,
 are already implemented in tstrings,
but i guess the speed increasement,
if there is one, may not significant.

meikl ;-)

Ok, lets try this again.  I just re-read your original request and realized I was only giving you the filename and not the last directory as well.  The following should work.

procedure Shorten(var fPath : string);
var
 ii : integer;
 count : integer;
 startPos,stop : integer;
 prevStop : integer;
begin
 count := 0;
 startPos := 0;
 stop := 0;
 prevStop := 0;
 for ii := 1 to length(fPath) do begin
   // look for all the separators
   if fPath[ii] = '\'  then begin
     count := count + 1;  // count them
     if count = 2 then startPos := ii + 1  // 2nd is start
     else begin
       prevStop := stop;
       stop := ii;
     end;
   end;
 end;
 if (count > 3) and (prevStop > (startPos + 2)) then begin
   // we had at least 4 separators and can shorten
   fPath[startPos] := '.';
   fPath[startPos+1] := '.';
   fPath[startPos+2] := '.';
   startPos := startPos + 3;  // elipses
   for ii := prevStop to length(fPath) do begin
     // copy the last separator and the filename
     fPath[startPos] := fPath[ii];
     startPos := startPos + 1;
   end;
   setLength(fPath,startPos - 1);  // shorten the string
 end;
end;

Meikl, you're right, of course. It was more a theoretical objection; I always try to get rid of TStringLists in such trivial cases (no matter if speed increase is insignificant or not.

Markus

Jbshumate, Good solution.

Hi Jbshumate,
Input string:
'c:\Program\c\d\a.exe'
Shorten proc can't dispose above path and will return original string. Should you update the proc to meet Mdlittle's request?

Just a suggestion. It doesn't matter.

merry prince

Your example would not in fact shorten based on his request.  The result would be c:\Program\...\d\a.exe.  I wrote the code to only operate if the result was shorter.

Just a suggestion. It doesn't matter.

btw: If someone uses/tests my code above: Set the autosize property of the label to false... (otherwise you'll just get the filename without the path ... not very useful then)

Markus

OK. The label thing will not work for me. I am not sending the short string to a label or any other control. This is not what I want. I am testing Jbshumate's and Meikl's code now.

Thanks

kretzschmar:

Very good  - works very well. Also works well for directory names as changed below;

result := sl[0]+'\'+sl[1]+'\...\' +sl[sl.count-1] + '\';

Glad to see you found something you like.  For what it is worth the code you chose is probably 1 to 2 orders of magnitude slower than what I showed you since it requires procedure calls, creation of a string list, try..except blocks etc.  As long as you are only doing this occasionally that would be no problem.  If you are using this to navigate a large number of paths and populate a treeView or some such you may want to keep this is mind.

jbshumate:

I do appreciate the suggestion and help with the question. It would be nice if you could also award points for effort and assistance.

I will watch for you name the next time I post a question.

Thanks again

Mike

I agreed with jbshumate. His proc is smart. Since no need to create and free object resource.