delphi 由绝对路径获得相对路径算法

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

 

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;