// 取两个目录的相对路径,注意串尾不能是'/'字符!
function GetRelativePath(Source, Dest: string): string;
//交换字串
function GetPathComp(s1, s2: string): integer;
procedure swapStr(var s1, s2: string);
var tempstr: string;
begin
tempstr := s1;
s1 := s2;
s2 := tempstr;
end;
//比较两路径字符串头部相同串的函数
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;
function RightSub(s: string; Len: Integer): string;
begin
Delete(s, 1, Length(s) - Len);
Result := s;
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;
//by 闫磊 Email:Landgis@126.com,yanleigis@21cn.com 2001.11.23
调用
procedure TForm1.Button1Click(Sender: TObject);
begin
showmessage(GetRelativePath('c:/test/aim', 'c:/test'));
end;