方法一:Boris Kumpar
function ExtractBasePath(const Path1,Path2:string):string;
const
PATH_DELIMITER = '\';
DRIVE_DELIMITER = ':';
var
P1,P2:PChar;
cnt,j:Integer;
begin
P1:=PChar(Path1) ;
P2:=PChar(Path2) ;
cnt := 1;
j := 0;
{$B-}
while (P1^ <> #0) and (P2^ <> #0) and (UpCase(P1^) = UpCase(P2^) ) do
begin
if (P1^=PATH_DELIMITER) or (P2^=PATH_DELIMITER) or ((j=0) and (P1^=DRIVE_DELIMITER)) then j:=cnt;
Inc(cnt) ;
Inc(P1) ;
Inc(P2) ;
end;
if (P1^=PATH_DELIMITER) or (P2^=PATH_DELIMITER) then j := cnt - 1;
Result:=Copy(Path1,1,j) ;
end;
方法二：Pablo Anizio
function ExtractBasePath(const path1, path2 : string) : string;
var
sP1, sP2, stemp, rslt: String;
slP1, slP2: TStringList;
dif: Boolean;
cnt, max: integer;
begin
rslt := EmptyStr;
if ((path1 <> EmptyStr) and (path2 <> EmptyStr)) then
begin
sP1 := ExtractFilePath(path1) ;
sP2 := ExtractFilePath(path2) ;
slP1 := TStringList.Create;
while length(sP1) <> 0 do
begin
stemp := Copy(sP1,1,pos('\',sP1)) ;
Delete(sP1,1,pos('\',sP1)) ;
slP1.Add(stemp) ;
end;
slP2 := TStringList.Create;
while length(sP2) <> 0 do
begin
stemp := Copy(sP2,1,pos('\',sP2)) ;
Delete(sP2,1,pos('\',sP2)) ;
slP2.Add(stemp) ;
end;
dif := False;
cnt := 0;
if (slP1.Count >= slP2.Count) then
max := slP2.Count
else
max := slP1.Count;
while (not dif) and (cnt < max) do
begin
if slP1.Strings[cnt] = slP2.Strings[cnt] then
rslt := rslt + slP1.Strings[cnt]
else
dif := True;
inc(cnt) ;
end;
slP1.Free;
slP2.Free;
end;
Result := rslt;
end;
方法三：Vlad Man
function ExtractBasePath(const path1, path2: string): string;
var
j: Integer;
vStrLength: Integer;
vLastDelemiterIndex: Integer;
begin
Result := '';
if Length(path1) > Length(path2) then
vStrLength := Length(path2)
else
vStrLength := Length(path1) ;
for j := 1 to vStrLength do
if path1[j] = path2[j] then
Result := Result + path1[j]
else
Break;
vLastDelemiterIndex := LastDelimiter('\', Result) ;
Delete(Result, vLastDelemiterIndex + 1, Length(Result) - vLastDelemiterIndex) ;
end;
方法四：Josip Brozovic
function ExtractBasePath( const path1, path2 : string ): string;
var
s_shorter, s_longer: string;
j: integer;
begin
if Length( path1 ) > Length( path2 ) then
begin
s_longer := path1;
s_shorter := path2;
end
else
begin
s_longer := path2;
s_shorter := path1;
end;
result := s_shorter;
for j := 1 to Length( s_shorter ) do
begin
if UpCase( path1[ j ] ) <> UpCase( path2[ j ] ) then
begin
Delete( result, j, MaxInt ) ;
break;
end;
end;
if ( result = s_shorter ) and
( Length( s_longer ) > Length( s_shorter )) and
( s_longer[ Length( s_shorter ) + 1 ] = '\' ) then
begin
result := result + '\';
end;
result := ExtractFilePath( result ) ;
end;
方法五：Korhan
function ExtractBasePath(const path1, path2 : string) : string;
var
minLength : Integer;
cnt : Integer;
samePart : String;
begin
if Length(path1) < Length(path2) then
minLength := length(path1)
else
minLength := length(path2) ;
Result := '';
samePart := '';
for cnt := 1 to minLength do
begin
if path1[cnt] = path2[cnt] then
begin
samePart := samePart + path1[cnt];
if (path1[cnt] = '\') or ( (Length(path1) = Length(path2)) and (minLength = cnt) ) then
begin
Result := Result + samePart;
samePart := '';
end;
end
else
Break;
end;
end;
方法六：Jeff Lawson
function ExtractBasePath(const Path1, Path2: string): string;
var
P1, P2,
Dir1, Dir2,
Base: string;
begin
Base := '';
P1 := LowerCase(Path1) ;
P2 := LowerCase(Path2) ;
if (ExtractFileExt(P1) = '') and (P1[Length(P1) - 1] <> '\') then P1 := P1 + '\';
if (ExtractFileExt(P2) = '') and (P2[Length(P2) - 1] <> '\') then P2 := P2 + '\';
while (P1 <> '') and (P2 <> '') do
begin
Dir1 := Copy(P1, 0, AnsiPos('\', P1)) ;
Dir2 := Copy(P2, 0, AnsiPos('\', P2)) ;
P1 := Copy(P1, Length(Dir1) + 1, Length(P1) - Length(Dir1) + 1) ;
P2 := Copy(P2, Length(Dir2) + 1, Length(P2) - Length(Dir2) + 1) ;
if Dir1 <> Dir2 then Break;
Base := Base + Dir1;
end;
Result := Base;
end;
方法七：Ivan Cvetkovic
function ExtractBasePath(const path1, path2 : string) : string;
procedure SplitPath(Path: string; sl: TStrings) ;
begin
sl.Delimiter := PathDelim;
sl.StrictDelimiter := True;
sl.DelimitedText := Path;
end;
var
sl1, sl2: TStrings;
cnt: Integer;
begin
Result := EmptyStr;
sl1 := TStringList.Create;
try
SplitPath(Path1, sl1) ;
sl2 := TStringList.Create;
try
SplitPath(Path2, sl2) ;
for cnt := 0 to Min(sl1.Count, sl2.count) - 1 do
begin
if not AnsiSameText(sl1[cnt], sl2[cnt]) then Break;
Result := Result + sl1[cnt] + PathDelim;
end;
finally
sl2.Free;
end;
finally
sl1.Free;
end;
end;
方法八：Paul Bennett
function ExtractBasePath(const Path1, Path2: string): string;
var
p1, p2, Matched: string;
PathDelimiter: string[1];
nStart, n1, n2, ctr: Integer;
begin
p1 := ExtractFilePath(Path1) ;
p2 := ExtractFilePath(Path2) ;
if (Length(p1) = 0) or (Length(p2) = 0) then Exit;
if CompareText(p1, p2) = 0 then
begin
Result:= p1;
Exit;
end;
PathDelimiter := p1[Length(p1)];
Matched := '';
nStart := 1;
repeat
n1 := PosEx(PathDelimiter, p1, nStart) ;
n2 := PosEx(PathDelimiter, p2, nStart) ;
if (n1 = n2) And (n1 <> 0) then
begin
for ctr:= nStart to n1 do
begin
if p1[ctr] <> p2[ctr] then Break;
end;
if ctr > n1 then
begin
Matched:= Matched +Copy(p1, nStart, ctr -nStart) ;
nStart := ctr;
end;
end;
until (n1 <> n2) or (ctr < n1) ;
if Length(Matched) > 2 then Matched := IncludeTrailingPathDelimiter(Matched) ;
Result:= Matched;
end;
方法九：Caleb Hattingh
function ExtractBasePath(const path1, path2 : string) : string;
var
tsl1, tsl2: TStringList;
j: Integer;
begin
Result := '';
tsl1 := TStringList.Create;
tsl2 := TStringList.Create;
try
tsl1.StrictDelimiter := True;
tsl2.StrictDelimiter := True;
tsl1.Delimiter := '\';
tsl1.DelimitedText := path1;
tsl2.Delimiter := '\';
tsl2.DelimitedText := path2;
for j := 0 to tsl1.Count - 1 do
begin
if tsl1[j] = tsl2[j] then
Result := Result + tsl1[j] + '\'
else
Exit;
end;
finally
FreeAndNil(tsl1) ;
FreeAndNil(tsl2) ;
end;
end;
方法十：Ricardo de O. Soares
function ExtractBasePath(const path1, path2: string): string;
var
cnt: integer;
begin
Result := '';
if UpCase(path1[1]) <> UpCase(path2[1]) then
Exit
else
begin
for cnt := 1 to Min(Length(path1),Length(path2)) do
if CompareText(LeftStr(path1,cnt),LeftStr(path2,cnt)) <> 0 then
break;
Result := Result + LeftStr(path1,cnt-1) ;
while RightStr(Result,1) <> '\' do
Delete(Result,Length(Result),1) ;
end;
end;
方法十一：Antonio Bakula
function ExtractBasePath(APath1, APath2: string): string;
var
tempRez: string;
xx, minLen: integer;
begin
minLen := Min(Length(APath1), Length(APath2)) ;
Result := '';
tempRez := '';
for xx := 1 to minLen do
begin
if APath1[xx] <> APath2[xx] then
Break;
tempRez := tempRez + APath1[xx];
if APath1[xx] = '\' then
Result := tempRez;
end;
end;
最后一种ASM:Jens Borrisholt:
function ExtractBasePath(const Path1, Path2: string): string;
var
CompareLength: Integer;
cnt: Integer;
P, Q: PChar;
begin
Result := '';
//Determent the shortest string
asm
mov eax, Path1
mov edx, Path2
test eax, edx //Test for nil string
jnz @NotNilString
mov esp, ebp
pop ebp
ret //restore registers and exit
@NotNilString:
mov ecx, [eax - 4]
cmp ecx, [edx - 4]
jle @Path2Shortest //Length(P1) > Length(P2)
mov ecx, [edx - 4]
@Path2Shortest:
mov CompareLength, ecx
end;
p := PChar(Path1) ;
q := PChar(Path2) ;
cnt := 1;
while cnt <= CompareLength do
if CSTR_EQUAL <> CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, P + cnt, 1, Q + cnt, 1) then
break
else
inc(cnt) ;
while (p[cnt] <> PathDelim) and (cnt > 0) do Dec(cnt) ;
if cnt <> 0 then SetString(Result, p, cnt + 1) ;
end;
本文来自Delphi之窗，原文地址：http://www.52delphi.com