求关于相对路径的函数

Question

用opendialog打开一个文件后，filename是文件的绝对路径，
求一函数，返回根据opendialog1.filename为参数的文件的相对路径，要求返回值为一string.

Answer 1

比如文件的绝对路径是c:\abc\123.txtExtractFileDir   c:\abc
ExtractFileDrive c:
ExtractFileExt   .txt
ExtractFileName  123.txt
ExtractFilePath  c:\abc\有你要的吗？

Answer 2

上面的不行，只能对文件类型的实现。
 使用递归函数。自己编写一个程序中可以使用
i:=pos('\',dirstr);  dirstr是路径，求解'\'的位置
copy(dirstr,i,len(dirstr)-i)进行递归复制

Answer 3

shlwapi.dll有一个函数PathRelativePathTo
Delphi里没有相应的Pascal申明，要自己写申明：function PathRelativePathTo(pszPath: LPSTR; pszFrom: LPCSTR; dwAttrFrom: DWORD ; pszTo: LPCSTR; dwAttrTo: DWORD ): BOOL;stdcall; external 'shlwapi.dll' name 'PathRelativePathToA';

Answer 4

一二楼的朋友的解答不合要求，相对路径是指opendialog1.filename相对于执行程序的路径。如假定执行程序为myprogram.exe位于D:\mypath\下，那么用一二楼朋友的方法得到的路径就不正确。
三楼的朋友：能不能提供一个pascal示例代码，因为需要的是讨论做这个符合要求的函数，而不是追求函数的结果。

Answer 5

越看越没看明白楼主的问题
如假定执行程序为myprogram.exe位于D:\mypath\下
----------------------------
那么你期望的“相对路径”是什么呢？

Answer 6

随手写了一个玩玩，测试通过，不知道是不是你要的：// 参数FromPath: 起始目录
// 参数FileName: 全路径文件名
function FileNameFromPath(FromPath, FileName: string): string;
var
  b, e: Integer;
  s: string;
begin
  if FromPath[1] <> FileName[1] then result := FileName
  else begin
    result := '';
    s := ExtractFilePath(FileName);
    b := 4;
    e := 4;
    while e <= length(FromPath) do
      if FromPath[e] <> s[e] then break
      else begin
        if s[e] = '\' then b := e + 1;
        inc(e);
      end;
    e := b;
    while e <= length(FromPath) do
    begin
      if FromPath[e] = '\' then result := result + '..\';
      inc(e);
    end;
    if result = '' then result := '.\';
    result := result + copy(FileName, b, length(FileName));
  end;
end;

Answer 7

发过的帖子怎么修改啊？上面代码有点小bug:
第一个循环条件改成:
  while (e<= length(FromPath)) and (e <= length(s)) do就没问题了。另外 if result = '' then result := '.\'可以不要。

Answer 8

function PathRelativePathTo(pszPath: LPSTR; pszFrom: LPCSTR; dwAttrFrom: DWORD ; pszTo: LPCSTR; dwAttrTo: DWORD ): BOOL;stdcall; external 'shlwapi.dll' name 'PathRelativePathToA';implementation{$R *.dfm}procedure TForm1.Button1Click(Sender: TObject);
var
    pszFrom, pszTo : LPTSTR;
    szPath : array[0..1024] of char;
begin
    pszFrom :='c:\FolderA\FolderB\FolderC';
    pszTo :='c:\FolderA\FolderD\FolderE';
    PathRelativePathTo(szPath,pszFrom,FILE_ATTRIBUTE_DIRECTORY,pszTo,FILE_ATTRIBUTE_DIRECTORY);
    ShowMessage(string(szPath));
end;end.

Answer 9

猛料里一个取相对路径的例子：======================
：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.