paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-27 10:41:50 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL: ExtractFileNameOnly reduced overhead

Browse Source 
git-svn-id: trunk@12788 -
This commit is contained in:
mattias 2007-11-08 16:32:49 +00:00
parent d8366cc6c0
commit 67c7ca8729
1 changed files with 14 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
lcl/include/fileutil.inc
View File

@ -709,11 +709,21 @@ end;
function ExtractFileNameOnly(const AFilename: string): string; function ExtractFileNameOnly(const AFilename: string): string;
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
function ExtractFileNameOnly(const AFilename: string): string; function ExtractFileNameOnly(const AFilename: string): string;
var ExtLen: integer; var
StartPos: Integer;
ExtPos: Integer;
begin begin
Result:=ExtractFilename(AFilename); StartPos:=length(AFilename)+1;
ExtLen:=length(ExtractFileExt(Result)); while (StartPos>1)
Result:=copy(Result,1,length(Result)-ExtLen); and (AFilename[StartPos-1]<>PathDelim)
{$IFDEF Windows}and (AFilename[StartPos-1]<>':'){$ENDIF}
do
dec(StartPos);
ExtPos:=length(AFilename);
while (ExtPos>=StartPos) and (AFilename[StartPos]<>'.') do
dec(ExtPos);
if (ExtPos<StartPos) then ExtPos:=length(AFilename)+1;
Result:=copy(AFilename,StartPos,ExtPos-StartPos);
end; end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------