paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-22 01:59:34 +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;
var ExtLen: integer;
var
StartPos: Integer;
ExtPos: Integer;
begin
Result:=ExtractFilename(AFilename);
ExtLen:=length(ExtractFileExt(Result));
Result:=copy(Result,1,length(Result)-ExtLen);
StartPos:=length(AFilename)+1;
while (StartPos>1)
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;
{------------------------------------------------------------------------------