：aimingoo, 时间：1998-9-10 8:47:56, ID：1637

uses SysUtils;

 //取右子串

Function RightSub(s:string; Len:Integer) : string;

begin

 Delete(s,1,Length(s)-Len);

 Result := s;

end;

 //交换字串

procedure swapStr(var s1,s2 : string);

 var tempstr : string;

begin

 tempstr := s1;

 s1 := s2;

 s2 := tempstr;

end;

 // 取两个目录的相对路径,注意串尾不能是'\'字符!

Function GetRelativePath(Source,Dest : string) : string;

 Function GetPathComp(s1,s2:string) : integer;

   //比较两路径字符串头部相同串的函数

 begin

   if length(s1) > Length(s2) then swapStr(s1,s2);

   Result := pos(s1,s2);

   while Result = 0 do

     begin

       if s1 = '' then exit;

       s1 := ExtractFileDir(s1);

       Result := pos(s1,s2);

     end;

   if Result <> 0 then Result := Length(s1);

   if Result = 3  then Result := 2;

     //修正因ExtractFileDir()处理'c:\'时产生的错误.

 End;

 Function GetRoot(s : ShortString) : string;

   //取Dest的相对根路径的函数

   var i : integer;

 begin

   Result := '';

   for i := 1 to Length(s) do

     if s[i] = '\' then Result := Result + '..\';

   if Result = '' then Result := '.\';

     //如果不想处理成".\"的路径格式，可去掉本行

 end;

var RelativRoot, RelativSub : string;

   HeadNum : integer;

begin

 Source := UpperCase(Source); Dest := UpperCase(Dest);

 //比较两路径字符串头部相同串

 HeadNum := GetPathComp(Source,Dest);

 //取Dest的相对根路径

 RelativRoot := GetRoot(RightSub(Dest,Length(Dest) - HeadNum));

 //取Source的相对子路径

 RelativSub := RightSub(Source,Length(Source) - HeadNum - 1);

 //返回

 Result := RelativRoot + RelativSub;

end;

begin

 /// TEST!!!

 Writeln(GetRelativePath('c:\test\aim','c:\test'));  // result = '.\aim'

 Writeln(GetRelativePath('c:\test','c:\test\1\2'));  // result = '..\..\'

 Writeln(GetRelativePath('c:\aim','c:\test'));       // result = '..\aim'

 Writeln(GetRelativePath('c:\dest\aim','c:\test\aim'));

    // result = '..\..\aim'

end.