[Back to DOS SWAG index]  [Back to Main SWAG index]  [Original]

{
bcp100@cd4680fs.rrze.uni-erlangen.de (Peter Gedeck)

: Does anyone have a relative path routine?   An example of what I mean by a
: relative path routine is the Turbo Pascal IDE's editor window titles. It
: only displays as much of the files path name as is necessary. It should be
: something like
:     function RelativePath(FullPath: string): string;

This is what I use to get a relative file name. I think it works correctly
and hope you will find it useful.
}

Uses
  Dos;


function GetCurDir : DirStr;
var
  CurDir : DirStr;
begin
  GetDir(0, CurDir);
  GetCurDir := CurDir;
end;


function GetCurDrive : Char; assembler;
asm
  MOV     AH,19H
  INT     21H
  ADD     AL,'A'
end;


function GetRelativeFileName(F : String) : String;
var
  D  : DirStr;
  N  : NameStr;
  E  : ExtStr;
  i  : integer;
  rd : string;

begin
  F := FExpand(F);
  FSplit(F, D, N, E);
  if GetCurDrive = D[1] then
  begin
    { Same Drive - remove Driveinformation from D }
    Delete(D, 1, 2);
    F := GetCurDir + '\';
    Delete(F, 1, 2);
    { Maybe it is a file in a directory higher than the actual directory }
    i := Pos(F, d);
    if i > 0 then
      Delete(d, 1, length(F))
    else
    begin
      rd := '';
      if Pos(d, F) = 0 then
      repeat
        repeat
          rd := d[Ord(d[0])] + rd;
          dec(d[0]);
        until d[Ord(d[0])] = '\';
      until Pos(d, F) > 0;

      { Maybe it  is a file in a directory lower than the actual directory }
      if Pos(d, F) > 0 then
      begin
        repeat
          rd := '..\' + rd;
          dec(F[0]);
          while F[Ord(F[0])] <> '\' do
            dec(F[0]);
        until (Pos(d, F) > 0) and not ((d = '\') and (F <> '\'));
        d := rd;
      end;
    end;
  end;
  GetRelativeFileName := (D + N + E);
end;


begin
  Writeln(GetRelativeFileName('C:\qmpro\dl\bp\lib\ansi.pas'));
end.

[Back to DOS SWAG index]  [Back to Main SWAG index]  [Original]