Code:

//==================================================

//All code herein is copyrighted by

//Peter Morris

//-----

//Do not alter / remove this copyright notice

//Email me at : Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра.

//

//The homepage for this library is https://www.droopyeyes.com

//

// CURRENT VERSION V3.2

//

//(Check out www.HowToDoThings.com for Delphi articles !)

//(Check out www.stuckindoors.com if you need a free events page on your site !)

//==================================================

unit FastStrings;

interface

uses

{$IFNDEF LINUX}

Windows,

{$ENDIF}

SysUtils;

//This TYPE declaration will become apparent later

type

TBMJumpTable = array[0..255] of Integer;

TFastPosProc = function (const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;

TFastPosIndexProc = function (const aSourceString, aFindString: string; const aSourceLen, aFindLen, StartPos: Integer; var JumpTable: TBMJumpTable): Integer;

TFastTagReplaceProc = procedure (var Tag: string; const UserData: Integer);

//Boyer-Moore routines

procedure MakeBMTable(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable);

procedure MakeBMTableNoCase(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable);

function BMPos(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;

function BMPosNoCase(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;

function FastAnsiReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags): string;

procedure FastCharMove(const Source; var Dest; Count : Integer);

function FastCharPos(const aSource : string; const C: Char; StartPos : Integer): Integer;

function FastCharPosNoCase(const aSource : string; C: Char; StartPos : Integer): Integer;

function FastPos(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;

function FastPosNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;

function FastPosBack(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;

function FastPosBackNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;

function FastReplace(const aSourceString : string; const aFindString, aReplaceString : string;

CaseSensitive : Boolean = False) : string;

function FastTagReplace(const SourceString, TagStart, TagEnd: string;

FastTagReplaceProc: TFastTagReplaceProc; const UserData: Integer): string;

function SmartPos(const SearchStr,SourceStr : string;

const CaseSensitive : Boolean = TRUE;

const StartPos : Integer = 1;

const ForwardSearch : Boolean = TRUE) : Integer;

implementation

const

cDeltaSize = 1.5;

var

GUpcaseTable : array[0..255] of char;

GUpcaseLUT: Pointer;

//MakeBMJumpTable takes a FindString and makes a JumpTable

procedure MakeBMTable(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable);

begin

if BufferLen = 0thenraise Exception.Create('BufferLen is 0');

asm

push EDI

push ESI

mov EDI, JumpTable

mov EAX, BufferLen

mov ECX, $100

REPNE STOSD

mov ECX, BufferLen

mov EDI, JumpTable

mov ESI, Buffer

dec ECX

xor EAX, EAX

@@loop:

mov AL, [ESI]

lea ESI, ESI + 1

mov [EDI + EAX * 4], ECX

dec ECX

jg @@loop

pop ESI

pop EDI

end;

end;

procedure MakeBMTableNoCase(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable);

begin

if BufferLen = 0thenraise Exception.Create('BufferLen is 0');

asm

push EDI

push ESI

mov EDI, JumpTable

mov EAX, BufferLen

mov ECX, $100

REPNE STOSD

mov EDX, GUpcaseLUT

mov ECX, BufferLen

mov EDI, JumpTable

mov ESI, Buffer

dec ECX

xor EAX, EAX

@@loop:

mov AL, [ESI]

lea ESI, ESI + 1

mov AL, [EDX + EAX]

mov [EDI + EAX * 4], ECX

dec ECX

jg @@loop

pop ESI

pop EDI

end;

end;

function BMPos(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;

var

LastPos: Pointer;

begin

LastPos := Pointer(Integer(aSource) + aSourceLen - 1);

asm

push ESI

push EDI

push EBX

mov EAX, aFindLen

mov ESI, aSource

lea ESI, ESI + EAX - 1

std

mov EBX, JumpTable

@@comparetext:

cmp ESI, LastPos

jg @@NotFound

mov EAX, aFindLen

mov EDI, aFind

mov ECX, EAX

push ESI //Remember where we are

lea EDI, EDI + EAX - 1

xor EAX, EAX

@@CompareNext:

mov al, [ESI]

cmp al, [EDI]

jne @@LookAhead

lea ESI, ESI - 1

lea EDI, EDI - 1

dec ECX

jz @@Found

jmp @@CompareNext

@@LookAhead:

//Look up the char in our Jump Table

pop ESI

mov al, [ESI]

mov EAX, [EBX + EAX * 4]

lea ESI, ESI + EAX

jmp @@CompareText

@@NotFound:

mov Result, 0

jmp @@TheEnd

@@Found:

pop EDI //We are just popping, we don't need the value

inc ESI

mov Result, ESI

@@TheEnd:

cld

pop EBX

pop EDI

pop ESI

end;

end;

function BMPosNoCase(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;

var

LastPos: Pointer;

begin

LastPos := Pointer(Integer(aSource) + aSourceLen - 1);

asm

push ESI

push EDI

push EBX

mov EAX, aFindLen

mov ESI, aSource

lea ESI, ESI + EAX - 1

std

mov EDX, GUpcaseLUT

@@comparetext:

cmp ESI, LastPos

jg @@NotFound

mov EAX, aFindLen

mov EDI, aFind

push ESI //Remember where we are

mov ECX, EAX

lea EDI, EDI + EAX - 1

xor EAX, EAX

@@CompareNext:

mov al, [ESI]

mov bl, [EDX + EAX]

mov al, [EDI]

cmp bl, [EDX + EAX]

jne @@LookAhead

lea ESI, ESI - 1

lea EDI, EDI - 1

dec ECX

jz @@Found

jmp @@CompareNext

@@LookAhead:

//Look up the char in our Jump Table

pop ESI

mov EBX, JumpTable

mov al, [ESI]

mov al, [EDX + EAX]

mov EAX, [EBX + EAX * 4]

lea ESI, ESI + EAX

jmp @@CompareText

@@NotFound:

mov Result, 0

jmp @@TheEnd

@@Found:

pop EDI //We are just popping, we don't need the value

inc ESI

mov Result, ESI

@@TheEnd:

cld

pop EBX

pop EDI

pop ESI

end;

end;

//NOTE : FastCharPos and FastCharPosNoCase do not require you to pass the length

// of the string, this was only done in FastPos and FastPosNoCase because

// they are used by FastReplace many times over, thus saving a LENGTH()

// operation each time. I can't see you using these two routines for the

// same purposes so I didn't do that this time !

function FastCharPos(const aSource : string; const C: Char; StartPos : Integer) : Integer;

var

L : Integer;

begin

//If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !!

Assert(StartPos > 0);

Result := 0;

L := Length(aSource);

if L = 0then exit;

if StartPos > L then exit;

Dec(StartPos);

asm

PUSH EDI //Preserve this register

mov EDI, aSource //Point EDI at aSource

add EDI, StartPos

mov ECX, L //Make a note of how many chars to search through

sub ECX, StartPos

mov AL, C //and which char we want

@Loop:

cmp Al, [EDI] //compare it against the SourceString

jz @Found

inc EDI

dec ECX

jnz @Loop

jmp @NotFound

@Found:

sub EDI, aSource //EDI has been incremented, so EDI-OrigAdress = Char pos !

inc EDI

mov Result, EDI

@NotFound:

POP EDI

end;

end;

function FastCharPosNoCase(const aSource : string; C: Char; StartPos : Integer) : Integer;

var

L : Integer;

begin

Result := 0;

L := Length(aSource);

if L = 0then exit;

if StartPos > L then exit;

Dec(StartPos);

if StartPos < 0then StartPos := 0;

asm

PUSH EDI //Preserve this register

PUSH EBX

mov EDX, GUpcaseLUT

mov EDI, aSource //Point EDI at aSource

add EDI, StartPos

mov ECX, L //Make a note of how many chars to search through

sub ECX, StartPos

xor EBX, EBX

mov BL, C

mov AL, [EDX+EBX]

@Loop:

mov BL, [EDI]

inc EDI

cmp Al, [EDX+EBX]

jz @Found

dec ECX

jnz @Loop

jmp @NotFound

@Found:

sub EDI, aSource //EDI has been incremented, so EDI-OrigAdress = Char pos !

mov Result, EDI

@NotFound:

POP EBX

POP EDI

end;

end;

//The first thing to note here is that I am passing the SourceLength and FindLength

//As neither Source or Find will alter at any point during FastReplace there is

//no need to call the LENGTH subroutine each time !

function FastPos(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;

var

JumpTable: TBMJumpTable;

begin

//If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !!

Assert(StartPos > 0);

if aFindLen < 1thenbegin

Result := 0;

exit;

end;

if aFindLen > aSourceLen thenbegin

Result := 0;

exit;

end;

MakeBMTable(PChar(aFindString), aFindLen, JumpTable);

Result := Integer(BMPos(PChar(aSourceString) + (StartPos - 1), PChar(aFindString),aSourceLen - (StartPos-1), aFindLen, JumpTable));

if Result > 0then

Result := Result - Integer(@aSourceString[1]) +1;

end;

function FastPosNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;

var

JumpTable: TBMJumpTable;

begin

//If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !!

Assert(StartPos > 0);

if aFindLen < 1thenbegin

Result := 0;

exit;

end;

if aFindLen > aSourceLen thenbegin

Result := 0;

exit;

end;

MakeBMTableNoCase(PChar(AFindString), aFindLen, JumpTable);

Result := Integer(BMPosNoCase(PChar(aSourceString) + (StartPos - 1), PChar(aFindString),aSourceLen - (StartPos-1), aFindLen, JumpTable));

if Result > 0then

Result := Result - Integer(@aSourceString[1]) +1;

end;

function FastPosBack(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;

var

SourceLen : Integer;

begin

if aFindLen < 1thenbegin

Result := 0;

exit;

end;

if aFindLen > aSourceLen thenbegin

Result := 0;

exit;

end;

if (StartPos = 0) or (StartPos + aFindLen > aSourceLen) then

SourceLen := aSourceLen - (aFindLen-1)

else

SourceLen := StartPos;

asm

push ESI

push EDI

push EBX

mov EDI, aSourceString

add EDI, SourceLen

Dec EDI

mov ESI, aFindString

mov ECX, SourceLen

Mov Al, [ESI]

@ScaSB:

cmp Al, [EDI]

jne @NextChar

@CompareStrings:

mov EBX, aFindLen

dec EBX

jz @FullMatch

@CompareNext:

mov Ah, [ESI+EBX]

cmp Ah, [EDI+EBX]

Jnz @NextChar

@Matches:

Dec EBX

Jnz @CompareNext

@FullMatch:

mov EAX, EDI

sub EAX, aSourceString

inc EAX

mov Result, EAX

jmp @TheEnd

@NextChar:

dec EDI

dec ECX

jnz @ScaSB

mov Result,0

@TheEnd:

pop EBX

pop EDI

pop ESI

end;

end;

function FastPosBackNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;

var

SourceLen : Integer;

begin

if aFindLen < 1thenbegin

Result := 0;

exit;

end;

if aFindLen > aSourceLen thenbegin

Result := 0;

exit;

end;

if (StartPos = 0) or (StartPos + aFindLen > aSourceLen) then

SourceLen := aSourceLen - (aFindLen-1)

else

SourceLen := StartPos;

asm

push ESI

push EDI

push EBX

mov EDI, aSourceString

add EDI, SourceLen

Dec EDI

mov ESI, aFindString

mov ECX, SourceLen

mov EDX, GUpcaseLUT

xor EBX, EBX

mov Bl, [ESI]

mov Al, [EDX+EBX]

@ScaSB:

mov Bl, [EDI]

cmp Al, [EDX+EBX]

jne @NextChar

@CompareStrings:

PUSH ECX

mov ECX, aFindLen

dec ECX

jz @FullMatch

@CompareNext:

mov Bl, [ESI+ECX]

mov Ah, [EDX+EBX]

mov Bl, [EDI+ECX]

cmp Ah, [EDX+EBX]

Jz @Matches

//Go back to findind the first char

POP ECX

Jmp @NextChar

@Matches:

Dec ECX

Jnz @CompareNext

@FullMatch:

POP ECX

mov EAX, EDI

sub EAX, aSourceString

inc EAX

mov Result, EAX

jmp @TheEnd

@NextChar:

dec EDI

dec ECX

jnz @ScaSB

mov Result,0

@TheEnd:

pop EBX

pop EDI

pop ESI

end;

end;

//My move is not as fast as MOVE when source and destination are both

//DWord aligned, but certainly faster when they are not.

//As we are moving characters in a string, it is not very likely at all that

//both source and destination are DWord aligned, so moving bytes avoids the

//cycle penality of reading/writing DWords across physical boundaries

procedure FastCharMove(const Source; var Dest; Count : Integer);

asm

//Note: When this function is called, delphi passes the parameters as follows

//ECX = Count

//EAX = Const Source

//EDX = Var Dest

//If no bytes to copy, just quit altogether, no point pushing registers

cmp ECX,0

Je @JustQuit

//Preserve the critical delphi registers

push ESI

push EDI

//move Source into ESI (generally the SOURCE register)

//move Dest into EDI (generally the DEST register for string commands)

//This may not actually be neccessary, as I am not using MOVsb etc

//I may be able just to use EAX and EDX, there may be a penalty for

//not using ESI, EDI but I doubt it, this is another thing worth trying !

mov ESI, EAX

mov EDI, EDX

//The following loop is the same as repNZ MovSB, but oddly quicker !

@Loop:

//Get the source byte

Mov AL, [ESI]

//Point to next byte

Inc ESI

//Put it into the Dest

mov [EDI], AL

//Point dest to next position

Inc EDI

//Dec ECX to note how many we have left to copy

Dec ECX

//If ECX <> 0 then loop

Jnz @Loop

//Another optimization note.

//Many people like to do this

//Mov AL, [ESI]

//Mov [EDI], Al

//Inc ESI

//Inc ESI

//There is a hidden problem here, I wont go into too much detail, but

//the pentium can continue processing instructions while it is still

//working out the result of INC ESI or INC EDI

//(almost like a multithreaded CPU)

//if, however, you go to use them while they are still being calculated

//the processor will stop until they are calculated (a penalty)

//Therefore I alter ESI and EDI as far in advance as possible of using them

//Pop the critical Delphi registers that we have altered

pop EDI

pop ESI

@JustQuit:

end;

function FastAnsiReplace(const S, OldPattern, NewPattern: string;

Flags: TReplaceFlags): string;

var

BufferSize, BytesWritten: Integer;

SourceString, FindString: string;

ResultPChar: PChar;

FindPChar, ReplacePChar: PChar;

SPChar, SourceStringPChar, PrevSourceStringPChar: PChar;

FinalSourceMarker: PChar;

SourceLength, FindLength, ReplaceLength, CopySize: Integer;

FinalSourcePosition: Integer;

begin

//Set up string lengths

BytesWritten := 0;

SourceLength := Length(S);

FindLength := Length(OldPattern);

ReplaceLength := Length(NewPattern);

//Quick exit

if (SourceLength = 0) or (FindLength = 0) or

(FindLength > SourceLength) then

begin

Result := S;

Exit;

end;

//Set up the source string and find string

if rfIgnoreCase in Flags then

begin

SourceString := AnsiUpperCase(S);

FindString := AnsiUpperCase(OldPattern);

endelse

begin

SourceString := S;

FindString := OldPattern;

end;

//Set up the result buffer size and pointers

try

if ReplaceLength <= FindLength then

//Result cannot be larger, only same size or smaller

BufferSize := SourceLength

else

//Assume a source string made entired of the sub string

BufferSize := (SourceLength * ReplaceLength) div

FindLength;

//10 times is okay for starters. We don't want to

//go allocating much more than we need.

if BufferSize > (SourceLength * 10) then

BufferSize := SourceLength * 10;

except

//Oops, integer overflow! Better start with a string

//of the same size as the source.

BufferSize := SourceLength;

end;

SetLength(Result, BufferSize);

ResultPChar := @Result[1];

//Set up the pointers to S and SourceString

SPChar := @S[1];

SourceStringPChar := @SourceString[1];

PrevSourceStringPChar := SourceStringPChar;

FinalSourceMarker := @SourceString[SourceLength - (FindLength - 1)];

//Set up the pointer to FindString

FindPChar := @FindString[1];

//Set the pointer to ReplaceString

if ReplaceLength > 0then

ReplacePChar := @NewPattern[1]

else

ReplacePChar := nil;

//Replace routine

repeat

//Find the sub string

SourceStringPChar := AnsiStrPos(PrevSourceStringPChar,

FindPChar);

if SourceStringPChar = nilthen Break;

//How many characters do we need to copy before

//the string occurs

CopySize := SourceStringPChar - PrevSourceStringPChar;

//Check we have enough space in our Result buffer

if CopySize + ReplaceLength > BufferSize - BytesWritten then

begin

BufferSize := Trunc((BytesWritten + CopySize + ReplaceLength) * cDeltaSize);

SetLength(Result, BufferSize);

ResultPChar := @Result[BytesWritten + 1];

end;

//Copy the preceeding characters to our result buffer

Move(SPChar^, ResultPChar^, CopySize);

Inc(BytesWritten, CopySize);

//Advance the copy position of S

Inc(SPChar, CopySize + FindLength);

//Advance the Result pointer

Inc(ResultPChar, CopySize);

//Copy the replace string into the Result buffer

if Assigned(ReplacePChar) then

begin

Move(ReplacePChar^, ResultPChar^, ReplaceLength);

Inc(ResultPChar, ReplaceLength);

Inc(BytesWritten, ReplaceLength);

end;

//Fake delete the start of the source string

PrevSourceStringPChar := SourceStringPChar + FindLength;

until (PrevSourceStringPChar > FinalSourceMarker) or

not (rfReplaceAll in Flags);

FinalSourcePosition := Integer(SPChar - @S[1]);

CopySize := SourceLength - FinalSourcePosition;

SetLength(Result, BytesWritten + CopySize);

if CopySize > 0then

Move(SPChar^, Result[BytesWritten + 1], CopySize);

end;

function FastReplace(const aSourceString : string; const aFindString, aReplaceString : string;

CaseSensitive : Boolean = False) : string;

var

PResult : PChar;

PReplace : PChar;

PSource : PChar;

PFind : PChar;

PPosition : PChar;

CurrentPos,

BytesUsed,

lResult,

lReplace,

lSource,

lFind : Integer;

Find : TFastPosProc;

CopySize : Integer;

JumpTable : TBMJumpTable;

begin

LSource := Length(aSourceString);

if LSource = 0thenbegin

Result := aSourceString;

exit;

end;

PSource := @aSourceString[1];

LFind := Length(aFindString);

if LFind = 0then exit;

PFind := @aFindString[1];

LReplace := Length(aReplaceString);

//Here we may get an Integer Overflow, or OutOfMemory, if so, we use a Delta

try

if LReplace <= LFind then

SetLength(Result,lSource)

else

SetLength(Result, (LSource *LReplace) div LFind);

except

SetLength(Result,0);

end;

LResult := Length(Result);

if LResult = 0thenbegin

LResult := Trunc((LSource + LReplace) * cDeltaSize);

SetLength(Result, LResult);

end;

PResult := @Result[1];

if CaseSensitive then

begin

MakeBMTable(PChar(AFindString), lFind, JumpTable);

Find := BMPos;

endelse

begin

MakeBMTableNoCase(PChar(AFindString), lFind, JumpTable);

Find := BMPosNoCase;

end;

BytesUsed := 0;

if LReplace > 0thenbegin

PReplace := @aReplaceString[1];

repeat

PPosition := Find(PSource,PFind,lSource, lFind, JumpTable);

if PPosition = nilthen break;

CopySize := PPosition - PSource;

Inc(BytesUsed, CopySize + LReplace);

if BytesUsed >= LResult thenbegin

//We have run out of space

CurrentPos := Integer(PResult) - Integer(@Result[1]) +1;

LResult := Trunc(LResult * cDeltaSize);

SetLength(Result,LResult);

PResult := @Result[CurrentPos];

end;

FastCharMove(PSource^,PResult^,CopySize);

Dec(lSource,CopySize + LFind);

Inc(PSource,CopySize + LFind);

Inc(PResult,CopySize);

FastCharMove(PReplace^,PResult^,LReplace);

Inc(PResult,LReplace);

until lSource < lFind;

endelsebegin

repeat

PPosition := Find(PSource,PFind,lSource, lFind, JumpTable);

if PPosition = nilthen break;

CopySize := PPosition - PSource;

FastCharMove(PSource^,PResult^,CopySize);

Dec(lSource,CopySize + LFind);

Inc(PSource,CopySize + LFind);

Inc(PResult,CopySize);

Inc(BytesUsed, CopySize);

until lSource < lFind;

end;

SetLength(Result, (PResult+LSource) - @Result[1]);

if LSource > 0then

FastCharMove(PSource^, Result[BytesUsed + 1], LSource);

end;

function FastTagReplace(const SourceString, TagStart, TagEnd: string;

FastTagReplaceProc: TFastTagReplaceProc; const UserData: Integer): string;

var

TagStartPChar: PChar;

TagEndPChar: PChar;

SourceStringPChar: PChar;

TagStartFindPos: PChar;

TagEndFindPos: PChar;

TagStartLength: Integer;

TagEndLength: Integer;

DestPChar: PChar;

FinalSourceMarkerStart: PChar;

FinalSourceMarkerEnd: PChar;

BytesWritten: Integer;

BufferSize: Integer;

CopySize: Integer;

ReplaceString: string;

procedure AddBuffer(const Buffer: Pointer; Size: Integer);

begin

if BytesWritten + Size > BufferSize then

begin

BufferSize := Trunc(BufferSize * cDeltaSize);

if BufferSize <= (BytesWritten + Size) then

BufferSize := Trunc((BytesWritten + Size) * cDeltaSize);

SetLength(Result, BufferSize);

DestPChar := @Result[BytesWritten + 1];

end;

Inc(BytesWritten, Size);

FastCharMove(Buffer^, DestPChar^, Size);

DestPChar := DestPChar + Size;

end;

begin

Assert(Assigned(@FastTagReplaceProc));

TagStartPChar := PChar(TagStart);

TagEndPChar := PChar(TagEnd);

if (SourceString = '') or (TagStart = '') or (TagEnd = '') then

begin

Result := SourceString;

Exit;

end;

SourceStringPChar := PChar(SourceString);

TagStartLength := Length(TagStart);

TagEndLength := Length(TagEnd);

FinalSourceMarkerEnd := SourceStringPChar + Length(SourceString) - TagEndLength;

FinalSourceMarkerStart := FinalSourceMarkerEnd - TagStartLength;

BytesWritten := 0;

BufferSize := Length(SourceString);

SetLength(Result, BufferSize);

DestPChar := @Result[1];

repeat

TagStartFindPos := AnsiStrPos(SourceStringPChar, TagStartPChar);

if (TagStartFindPos = nil) or (TagStartFindPos > FinalSourceMarkerStart) then Break;

TagEndFindPos := AnsiStrPos(TagStartFindPos + TagStartLength, TagEndPChar);

if (TagEndFindPos = nil) or (TagEndFindPos > FinalSourceMarkerEnd) then Break;

CopySize := TagStartFindPos - SourceStringPChar;

AddBuffer(SourceStringPChar, CopySize);

CopySize := TagEndFindPos - (TagStartFindPos + TagStartLength);

SetLength(ReplaceString, CopySize);

if CopySize > 0then

Move((TagStartFindPos + TagStartLength)^, ReplaceString[1], CopySize);

FastTagReplaceProc(ReplaceString, UserData);

if Length(ReplaceString) > 0then

AddBuffer(@ReplaceString[1], Length(ReplaceString));

SourceStringPChar := TagEndFindPos + TagEndLength;

until SourceStringPChar > FinalSourceMarkerStart;

CopySize := PChar(@SourceString[Length(SourceString)]) - (SourceStringPChar - 1);

if CopySize > 0then

AddBuffer(SourceStringPChar, CopySize);

SetLength(Result, BytesWritten);

end;

function SmartPos(const SearchStr,SourceStr : string;

const CaseSensitive : Boolean = TRUE;

const StartPos : Integer = 1;

const ForwardSearch : Boolean = TRUE) : Integer;

begin

// NOTE: When using StartPos, the returned value is absolute!

if (CaseSensitive) then

if (ForwardSearch) then

Result:=

FastPos(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)

else

Result:=

FastPosBack(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)

else

if (ForwardSearch) then

Result:=

FastPosNoCase(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)

else

Result:=

FastPosBackNoCase(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)

end;

var

I: Integer;

initialization

{$IFNDEF LINUX}

for I:=0to255do GUpcaseTable[I] := Chr(I);

CharUpperBuff(@GUpcaseTable[0], 256);

{$ELSE}

for I:=0to255do GUpcaseTable[I] := UpCase(Chr(I));

{$ENDIF}

GUpcaseLUT := @GUpcaseTable[0];

end.

FastStringFuncs.pas

//==================================================

//All code herein is copyrighted by

//Peter Morris

//-----

//Do not alter / remove this copyright notice

//Email me at : Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра.

//

//The homepage for this library is https://www.droopyeyes.com

//

//(Check out www.HowToDoThings.com for Delphi articles !)

//(Check out www.stuckindoors.com if you need a free events page on your site !)

unit FastStringFuncs;

interface

uses

{$IFDEF LINUX}

QGraphics,

{$ELSE}

Graphics,

{$ENDIF}

FastStrings, Sysutils, Classes;

const

cHexChars = '0123456789ABCDEF';

cSoundexTable: array[65..122] of Byte =

({A}0, {B}1, {C}2, {D}3, {E}0, {F}1, {G}2, {H}0, {I}0, {J}2, {K}2, {L}4, {M}5,

{N}5, {O}0, {P}1, {Q}2, {R}6, {S}2, {T}3, {U}0, {V}1, {W}0, {X}2, {Y}0, {Z}2,

0, 0, 0, 0, 0, 0,

{a}0, {b}1, {c}2, {d}3, {e}0, {f}1, {g}2, {h}0, {i}0, {j}2, {k}2, {l}4, {m}5,

{n}5, {o}0, {p}1, {q}2, {r}6, {s}2, {t}3, {u}0, {v}1, {w}0, {x}2, {y}0, {z}2);

function Base64Encode(const Source: AnsiString): AnsiString;

function Base64Decode(const Source: string): string;

function CopyStr(const aSourceString : string; aStart, aLength : Integer) : string;

function Decrypt(const S: string; Key: Word): string;

function Encrypt(const S: string; Key: Word): string;

function ExtractHTML(S : string) : string;

function ExtractNonHTML(S : string) : string;

function HexToInt(aHex : string) : int64;

function LeftStr(const aSourceString : string; Size : Integer) : string;

function StringMatches(Value, Pattern : string) : Boolean;

function MissingText(Pattern, Source : string; SearchText : string = '?') : string;

function RandomFileName(aFilename : string) : string;

function RandomStr(aLength : Longint) : string;

function ReverseStr(const aSourceString: string): string;

function RightStr(const aSourceString : string; Size : Integer) : string;

function RGBToColor(aRGB : string) : TColor;

function StringCount(const aSourceString, aFindString : string; Const CaseSensitive : Boolean = TRUE) : Integer;

function SoundEx(const aSourceString: string): Integer;

function UniqueFilename(aFilename : string) : string;

function URLToText(aValue : string) : string;

function WordAt(Text : string; Position : Integer) : string;

procedure Split(aValue : string; aDelimiter : Char; var Result : TStrings);

implementation

const

cKey1 = 52845;

cKey2 = 22719;

Base64_Table : shortstring = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function StripHTMLorNonHTML(const S : string; WantHTML : Boolean) : string; forward;

//Encode to Base64

function Base64Encode(const Source: AnsiString): AnsiString;

var

NewLength: Integer;

begin

NewLength := ((2 + Length(Source)) div3) * 4;

SetLength( Result, NewLength);

asm

Push ESI

Push EDI

Push EBX

Lea EBX, Base64_Table

Inc EBX // Move past String Size (ShortString)

Mov EDI, Result

Mov EDI, [EDI]

Mov ESI, Source

Mov EDX, [ESI-4] //Length of Input String

@WriteFirst2:

CMP EDX, 0

JLE @Done

MOV AL, [ESI]

SHR AL, 2

{$IFDEF VER140}// Changes to BASM in D6

XLATB

{$ELSE}

XLAT

{$ENDIF}

MOV [EDI], AL

INC EDI

MOV AL, [ESI + 1]

MOV AH, [ESI]

SHR AX, 4

AND AL, 63

{$IFDEF VER140}// Changes to BASM in D6

XLATB

{$ELSE}

XLAT

{$ENDIF}

MOV [EDI], AL

INC EDI

CMP EDX, 1

JNE @Write3

MOV AL, 61// Add ==

MOV [EDI], AL

INC EDI

MOV [EDI], AL

INC EDI

JMP @Done

@Write3:

MOV AL, [ESI + 2]

MOV AH, [ESI + 1]

SHR AX, 6

AND AL, 63

{$IFDEF VER140}// Changes to BASM in D6

XLATB

{$ELSE}

XLAT

{$ENDIF}

MOV [EDI], AL

INC EDI

CMP EDX, 2

JNE @Write4

MOV AL, 61// Add =

MOV [EDI], AL

INC EDI

JMP @Done

@Write4:

MOV AL, [ESI + 2]

AND AL, 63

{$IFDEF VER140}// Changes to BASM in D6

XLATB

{$ELSE}

XLAT

{$ENDIF}

MOV [EDI], AL

INC EDI

ADD ESI, 3

SUB EDX, 3

JMP @WriteFirst2

@done:

Pop EBX

Pop EDI

Pop ESI

end;

end;

//Decode Base64

function Base64Decode(const Source: string): string;

var

NewLength: Integer;

begin

{

NB: On invalid input this routine will simply skip the bad data, a

better solution would probably report the error

ESI -> Source String

EDI -> Result String

ECX -> length of Source (number of DWords)

EAX -> 32 Bits from Source

EDX -> 24 Bits Decoded

BL -> Current number of bytes decoded

}

SetLength( Result, (Length(Source) div4) * 3);

NewLength := 0;

asm

Push ESI

Push EDI

Push EBX

Mov ESI, Source

Mov EDI, Result //Result address

Mov EDI, [EDI]

Or ESI,ESI // Nil Strings

Jz @Done

Mov ECX, [ESI-4]

Shr ECX,2// DWord Count

JeCxZ @Error // Empty String

Cld

jmp @Read4

@Next:

Dec ECX

Jz @Done

@Read4:

lodsd

Xor BL, BL

Xor EDX, EDX

Call @DecodeTo6Bits

Shl EDX, 6

Shr EAX,8

Call @DecodeTo6Bits

Shl EDX, 6

Shr EAX,8

Call @DecodeTo6Bits

Shl EDX, 6

Shr EAX,8

Call @DecodeTo6Bits

// Write Word

Or BL, BL

JZ @Next // No Data

Dec BL

Or BL, BL

JZ @Next // Minimum of 2 decode values to translate to 1 byte

Mov EAX, EDX

Cmp BL, 2

JL @WriteByte

Rol EAX, 8

BSWAP EAX

StoSW

Add NewLength, 2

@WriteByte:

Cmp BL, 2

JE @Next

SHR EAX, 16

StoSB

Inc NewLength

jmp @Next

@Error:

jmp @Done

@DecodeTo6Bits:

@TestLower:

Cmp AL, 'a'

Jl @TestCaps

Cmp AL, 'z'

Jg @Skip

Sub AL, 71

Jmp @Finish

@TestCaps:

Cmp AL, 'A'

Jl @TestEqual

Cmp AL, 'Z'

Jg @Skip

Sub AL, 65

Jmp @Finish

@TestEqual:

Cmp AL, '='

Jne @TestNum

// Skip byte

ret

@TestNum:

Cmp AL, '9'

Jg @Skip

Cmp AL, '0'

JL @TestSlash

Add AL, 4

Jmp @Finish

@TestSlash:

Cmp AL, '/'

Jne @TestPlus

Mov AL, 63

Jmp @Finish

@TestPlus:

Cmp AL, '+'

Jne @Skip

Mov AL, 62

@Finish:

Or DL, AL

Inc BL

@Skip:

Ret

@Done:

Pop EBX

Pop EDI

Pop ESI

end;

SetLength( Result, NewLength); // Trim off the excess

end;

//Encrypt a string

function Encrypt(const S: string; Key: Word): string;

var

I: byte;

begin

SetLength(result,length(s));

for I := 1to Length(S) do

begin

Result[I] := char(byte(S[I]) xor (Key shr8));

Key := (byte(Result[I]) + Key) * cKey1 + cKey2;

end;

end;

//Return only the HTML of a string

function ExtractHTML(S : string) : string;

begin

Result := StripHTMLorNonHTML(S, True);

end;

function CopyStr(const aSourceString : string; aStart, aLength : Integer) : string;

var

L : Integer;

begin

L := Length(aSourceString);

if L=0then Exit;

if (aStart < 1) or (aLength < 1) then Exit;

if aStart + (aLength-1) > L then aLength := L - (aStart-1);

if (aStart <1) then exit;

SetLength(Result,aLength);

FastCharMove(aSourceString[aStart], Result[1], aLength);

end;

//Take all HTML out of a string

function ExtractNonHTML(S : string) : string;

begin

Result := StripHTMLorNonHTML(S,False);

end;

//Decrypt a string encoded with Encrypt

function Decrypt(const S: string; Key: Word): string;

var

I: byte;

begin

SetLength(result,length(s));

for I := 1to Length(S) do

begin

Result[I] := char(byte(S[I]) xor (Key shr8));

Key := (byte(S[I]) + Key) * cKey1 + cKey2;

end;

end;

//Convert a text-HEX value (FF0088 for example) to an integer

function HexToInt(aHex : string) : int64;

var

Multiplier : Int64;

Position : Byte;

Value : Integer;

begin

Result := 0;

Multiplier := 1;

Position := Length(aHex);

while Position >0dobegin

Value := FastCharPosNoCase(cHexChars, aHex[Position], 1)-1;

if Value = -1then

raise Exception.Create('Invalid hex character ' + aHex[Position]);

Result := Result + (Value * Multiplier);

Multiplier := Multiplier * 16;

Dec(Position);

end;

end;

//Get the left X amount of chars

function LeftStr(const aSourceString : string; Size : Integer) : string;

begin

if Size > Length(aSourceString) then

Result := aSourceString

elsebegin

SetLength(Result, Size);

Move(aSourceString[1],Result[1],Size);

end;

end;

//Do strings match with wildcards, eg

//StringMatches('The cat sat on the mat', 'The * sat * the *') = True

function StringMatches(Value, Pattern : string) : Boolean;

var

NextPos,

Star1,

Star2 : Integer;

NextPattern : string;

begin

Star1 := FastCharPos(Pattern,'*',1);

if Star1 = 0then

Result := (Value = Pattern)

else

begin

Result := (Copy(Value,1,Star1-1) = Copy(Pattern,1,Star1-1));

if Result then

begin

if Star1 > 1then Value := Copy(Value,Star1,Length(Value));

Pattern := Copy(Pattern,Star1+1,Length(Pattern));

NextPattern := Pattern;

Star2 := FastCharPos(NextPattern, '*',1);

if Star2 > 0then NextPattern := Copy(NextPattern,1,Star2-1);

//pos(NextPattern,Value);

NextPos := FastPos(Value, NextPattern, Length(Value), Length(NextPattern), 1);

if (NextPos = 0) andnot (NextPattern = '') then

Result := False

else

begin

Value := Copy(Value,NextPos,Length(Value));

if Pattern = ''then

Result := True

else

Result := Result and StringMatches(Value,Pattern);

end;

end;

end;

end;

//Missing text will tell you what text is missing, eg

//MissingText('the ? sat on the mat','the cat sat on the mat','?') = 'cat'

function MissingText(Pattern, Source : string; SearchText : string = '?') : string;

var

Position : Longint;

BeforeText,

AfterText : string;

BeforePos,

AfterPos : Integer;

lSearchText,

lBeforeText,

lAfterText,

lSource : Longint;

begin

Result := '';

Position := Pos(SearchText,Pattern);

if Position = 0then exit;

lSearchText := Length(SearchText);

lSource := Length(Source);

BeforeText := Copy(Pattern,1,Position-1);

AfterText := Copy(Pattern,Position+lSearchText,lSource);

lBeforeText := Length(BeforeText);

lAfterText := Length(AfterText);

AfterPos := lBeforeText;

repeat

AfterPos := FastPosNoCase(Source,AfterText,lSource,lAfterText,AfterPos+lSearchText);

if AfterPos > 0thenbegin

BeforePos := FastPosBackNoCase(Source,BeforeText,AfterPos-1,lBeforeText,AfterPos - (lBeforeText-1));

if (BeforePos > 0) thenbegin

Result := Copy(Source,BeforePos + lBeforeText, AfterPos - (BeforePos + lBeforeText));

Break;

end;

end;

until AfterPos = 0;

end;

//Generates a random filename but preserves the original path + extension

function RandomFilename(aFilename : string) : string;

var

Path,

Filename,

Ext : string;

begin

Result := aFilename;

Path := ExtractFilepath(aFilename);

Ext := ExtractFileExt(aFilename);

Filename := ExtractFilename(aFilename);

if Length(Ext) > 0then

Filename := Copy(Filename,1,Length(Filename)-Length(Ext));

repeat

Result := Path + RandomStr(32) + Ext;

untilnot FileExists(Result);

end;

//Makes a string of aLength filled with random characters

function RandomStr(aLength : Longint) : string;

var

X : Longint;

begin

if aLength <= 0then exit;

SetLength(Result, aLength);

for X:=1to aLength do

Result[X] := Chr(Random(26) + 65);

end;

function ReverseStr(const aSourceString: string): string;

var

L : Integer;

S,

D : Pointer;

begin

L := Length(aSourceString);

SetLength(Result,L);

if L = 0then exit;

S := @aSourceString[1];

D := @Result[L];

asm

push ESI

push EDI

mov ECX, L

mov ESI, S

mov EDI, D

@Loop:

mov Al, [ESI]

inc ESI

mov [EDI], Al

dec EDI

dec ECX

jnz @Loop

pop EDI

pop ESI

end;

end;

//Returns X amount of chars from the right of a string

function RightStr(const aSourceString : string; Size : Integer) : string;

begin

if Size > Length(aSourceString) then

Result := aSourceString

elsebegin

SetLength(Result, Size);

FastCharMove(aSourceString[Length(aSourceString)-(Size-1)],Result[1],Size);

end;

end;

//Converts a typical HTML RRGGBB color to a TColor

function RGBToColor(aRGB : string) : TColor;

begin

if Length(aRGB) < 6thenraise EConvertError.Create('Not a valid RGB value');

if aRGB[1] = '#'then aRGB := Copy(aRGB,2,Length(aRGB));

if Length(aRGB) <> 6thenraise EConvertError.Create('Not a valid RGB value');

Result := HexToInt(aRGB);

asm

mov EAX, Result

BSwap EAX

shr EAX, 8

mov Result, EAX

end;

end;

//Splits a delimited text line into TStrings (does not account for stuff in quotes but it should)

procedure Split(aValue : string; aDelimiter : Char; var Result : TStrings);

var

X : Integer;

S : string;

begin

if Result = nilthen Result := TStringList.Create;

Result.Clear;

S := '';

for X:=1to Length(aValue) dobegin

if aValue[X] <> aDelimiter then

S:=S + aValue[X]

elsebegin

Result.Add(S);

S := '';

end;

end;

if S <> ''then Result.Add(S);

end;

//counts how many times a substring exists within a string

//StringCount('XXXXX','XX') would return 2

function StringCount(const aSourceString, aFindString : string; Const CaseSensitive : Boolean = TRUE) : Integer;

var

Find,

Source,

NextPos : PChar;

LSource,

LFind : Integer;

Next : TFastPosProc;

JumpTable : TBMJumpTable;

begin

Result := 0;

LSource := Length(aSourceString);

if LSource = 0then exit;

LFind := Length(aFindString);

if LFind = 0then exit;

if CaseSensitive then

begin

Next := BMPos;

MakeBMTable(PChar(aFindString), Length(aFindString), JumpTable);

endelse

begin

Next := BMPosNoCase;

MakeBMTableNoCase(PChar(aFindString), Length(aFindString), JumpTable);

end;

Source := @aSourceString[1];

Find := @aFindString[1];

repeat

NextPos := Next(Source, Find, LSource, LFind, JumpTable);

if NextPos <> nilthen

begin

Dec(LSource, (NextPos - Source) + LFind);

Inc(Result);

Source := NextPos + LFind;

end;

until NextPos = nil;

end;

function SoundEx(const aSourceString: string): Integer;

var

CurrentChar: PChar;

I, S, LastChar, SoundexGroup: Byte;

Multiple: Word;

begin

if aSourceString = ''then

Result := 0

else

begin

//Store first letter immediately

Result := Ord(Upcase(aSourceString[1]));

//Last character found = 0

LastChar := 0;

Multiple := 26;

//Point to first character

CurrentChar := @aSourceString[1];

for I := 1to Length(aSourceString) do

begin

Inc(CurrentChar);

S := Ord(CurrentChar^);

if (S > 64) and (S < 123) then

begin

SoundexGroup := cSoundexTable[S];

if (SoundexGroup <> LastChar) and (SoundexGroup > 0) then

begin

Inc(Result, SoundexGroup * Multiple);

if Multiple = 936then Break; {26 * 6 * 6}

Multiple := Multiple * 6;

LastChar := SoundexGroup;

end;

end;

end;

end;

end;

//Used by ExtractHTML and ExtractNonHTML

function StripHTMLorNonHTML(const S : string; WantHTML : Boolean) : string;

var

X: Integer;

TagCnt: Integer;

ResChar: PChar;

SrcChar: PChar;

begin

TagCnt := 0;

SetLength(Result, Length(S));

if Length(S) = 0then Exit;

ResChar := @Result[1];

SrcChar := @S[1];

for X:=1to Length(S) do

begin

case SrcChar^ of

'<':

begin

Inc(TagCnt);

if WantHTML and (TagCnt = 1) then

begin

ResChar^ := '<';

Inc(ResChar);

end;

end;

'>':

begin

Dec(TagCnt);

if WantHTML and (TagCnt = 0) then

begin

ResChar^ := '>';

Inc(ResChar);

end;

end;

else

case WantHTML of

False:

if TagCnt <= 0then

begin

ResChar^ := SrcChar^;

Inc(ResChar);

TagCnt := 0;

end;

True:

if TagCnt >= 1then

begin

ResChar^ := SrcChar^;

Inc(ResChar);

endelse

if TagCnt < 0then TagCnt := 0;

end;

end;

Inc(SrcChar);

end;

SetLength(Result, ResChar - PChar(@Result[1]));

Result := FastReplace(Result, '&nbsp;', ' ', False);

Result := FastReplace(Result,'&amp;','&', False);

Result := FastReplace(Result,'&lt;','<', False);

Result := FastReplace(Result,'&gt;','>', False);

Result := FastReplace(Result,'&quot;','"', False);

end;

//Generates a UniqueFilename, makes sure the file does not exist before returning a result

function UniqueFilename(aFilename : string) : string;

var

Path,

Filename,

Ext : string;

Index : Integer;

begin

Result := aFilename;

if FileExists(aFilename) thenbegin

Path := ExtractFilepath(aFilename);

Ext := ExtractFileExt(aFilename);

Filename := ExtractFilename(aFilename);

if Length(Ext) > 0then

Filename := Copy(Filename,1,Length(Filename)-Length(Ext));

Index := 2;

repeat

Result := Path + Filename + IntToStr(Index) + Ext;

Inc(Index);

untilnot FileExists(Result);

end;

end;

//Decodes all that %3c stuff you get in a URL

function URLToText(aValue : string) : string;

var

X : Integer;

begin

Result := '';

X := 1;

while X <= Length(aValue) dobegin

if aValue[X] <> '%'then

Result := Result + aValue[X]

elsebegin

Result := Result + Chr( HexToInt( Copy(aValue,X+1,2) ) );

Inc(X,2);

end;

Inc(X);

end;

end;

//Returns the whole word at a position

function WordAt(Text : string; Position : Integer) : string;

var

L,

X : Integer;

begin

Result := '';

L := Length(Text);

if (Position > L) or (Position < 1) then Exit;

for X:=Position to L dobegin

if Upcase(Text[X]) in ['A'..'Z','0'..'9'] then

Result := Result + Text[X]

else

Break;

end;

for X:=Position-1downto1dobegin

if Upcase(Text[X]) in ['A'..'Z','0'..'9'] then

Result := Text[X] + Result

else

Break;

end;

end;

end.

Code:

unit TrimStr;

{$B-}

{

Файл: TrimStr

Автор: Bob Swart [100434,2072]

Описание: программы для удаления конечных/начальных пробелов

и левых/правых частей строк (аналог Basic-функций).

Версия: 2.0

LTrim() - Удаляем все пробелы в левой части строки

RTrim() - Удаляем все пробелы в правой части строки

Trim() - Удаляем все пробелы по краям строки

RightStr() - Возвращаем правую часть стоки заданной длины

LeftStr() - Возвращаем левую часть стоки заданной длины

MidStr() - Возвращаем центральную часть строки

}

interface

const

Space = #$20;

function LTrim(const Str: string): string;

function RTrim(Str: string): string;

function Trim(Str: string): string;

function RightStr(const Str: string; Size: Word): string;

function LeftStr(const Str: string; Size: Word): string;

function MidStr(const Str: string; Size: Word): string;

implementation

function LTrim(const Str: string): string;

var

len: Byte absolute Str;

i: Integer;

begin

i := 1;

while (i <= len) and (Str[i] = Space) do

Inc(i);

LTrim := Copy(Str, i, len)

end{LTrim};

function RTrim(Str: string): string;

var

len: Byte absolute Str;

begin

while (Str[len] = Space) do

Dec(len);

RTrim := Str

end{RTrim};

function Trim(Str: string): string;

begin

Trim := LTrim(RTrim(Str))

end{Trim};

function RightStr(const Str: string; Size: Word): string;

var

len: Byte absolute Str;

begin

if Size > len then

Size := len;

RightStr := Copy(Str, len - Size + 1, Size)

end{RightStr};

function LeftStr(const Str: string; Size: Word): string;

begin

LeftStr := Copy(Str, 1, Size)

end{LeftStr};

function MidStr(const Str: string; Size: Word): string;

var

len: Byte absolute Str;

begin

if Size > len then

Size := len;

MidStr := Copy(Str, ((len - Size) div2) + 1, Size)

end{MidStr};

end.

// *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*

const

BlackSpace = [#33..#126];

{

squish() возвращает строку со всеми белыми пробелами и с удаленными

повторяющимися апострофами.

}

function squish(const Search: string): string;

var

Index: byte;

InString: boolean;

begin

InString := False;

Result := '';

forIndex := 1to Length(Search) do

begin

if InString or (Search[Index] in BlackSpace) then

AppendStr(Result, Search[Index]);

InString := ((Search[Index] = '''') and (Search[Index - 1] <> '\'))

xor InString;

end;

end;

{

before() возвращает часть стоки, находящейся перед

первой найденной подстроки Find в строке Search. Если

Find не найдена, функция возвращает Search.

}

function before(const Search, Find: string): string;

var

index: byte;

begin

index := Pos(Find, Search);

ifindex = 0then

Result := Search

else

Result := Copy(Search, 1, index - 1);

end;

{

after() возвращает часть строки, находящейся после

первой найденной подстроки Find в строке Search. Если

Find не найдена, функция возвращает NULL.

}

function after(const Search, Find: string): string;

var

index: byte;

begin

index := Pos(Find, Search);

ifindex = 0then

Result := ''

else

Result := Copy(Search, index + Length(Find), 255);

end;

{

RPos() возвращает первый символ последней найденной

подстроки Find в строке Search. Если Find не найдена,

функция возвращает 0. Подобна реверсированной Pos().

}

function RPos(const Find, Search: string): byte;

var

FindPtr, SearchPtr, TempPtr: PChar;

begin

FindPtr := StrAlloc(Length(Find) + 1);

SearchPtr := StrAlloc(Length(Search) + 1);

StrPCopy(FindPtr, Find);

StrPCopy(SearchPtr, Search);

Result := 0;

repeat

TempPtr := StrRScan(SearchPtr, FindPtr^);

if TempPtr <> nilthen

if (StrLComp(TempPtr, FindPtr, Length(Find)) = 0) then

begin

Result := TempPtr - SearchPtr + 1;

TempPtr := nil;

end

else

TempPtr := #0;

until TempPtr = nil;

end;

{

inside() возвращает подстроку, вложенную между парой

подстрок Front ... Back.

}

function inside(const Search, Front, Back: string): string;

var

Index, Len: byte;

begin

Index := RPos(Front, before(Search, Back));

Len := Pos(Back, Search);

if (Index > 0) and (Len > 0) then

Result := Copy(Search, Index + 1, Len - (Index + 1))

else

Result := '';

end;

{

leftside() возвращает левую часть "отстатка" inside() или Search.

}

function leftside(const Search, Front, Back: string): string;

begin

Result := before(Search, Front + inside(Search, Front, Back) + Back);

end;

{

rightside() возвращает правую часть "остатка" inside() или Null.

}

function rightside(const Search, Front, Back: string): string;

begin

Result := after(Search, Front + inside(Search, Front, Back) + Back);

end;

{

trim() возвращает строку со всеми удаленными по краям белыми пробелами.

}

function trim(const Search: string): string;

var

Index: byte;

begin

Index := 1;

while (Index <= Length(Search)) andnot (Search[Index] in BlackSpace) do

Index := Index + 1;

Result := Copy(Search, Index, 255);

Index := Length(Result);

while (Index > 0) andnot (Result[Index] in BlackSpace) do

Index := Index - 1;

Result := Copy(Result, 1, Index);

end;

Code:

uses

Word_TLB;

...

var

WordApp: _Application;

WordDoc: _Document;

VarFalse: OleVariant;

begin

WordApp := CoApplication.Create;

WordDoc := WordApp.Documents.Add(EmptyParam, EmptyParam);

{

код для проверки орфографии, описываемы далее в данной статье

}

VarFalse:=False;

WordApp.Quit(VarFalse, EmptyParam, EmptyParam);

end;

Code:

uses

ComObj;

...

var

WordApp, WordDoc: Variant;

begin

WordApp := CreateOleObject('Word.Application');

WordDoc := WordApp.Documents.Add;

{

код для проверки орфографии, описываемы далее в данной статье

}

WordApp.Quit(False)

end;

Code:

procedure TForm1.btnSpellCheckClick(Sender: TObject);

var

colSpellErrors : ProofreadingErrors;

colSuggestions : SpellingSuggestions;

i : Integer;

StopLoop : Boolean;

itxtLen, itxtStart : Integer;

varFalse : OleVariant;

begin

WordApp.Connect;

WordDoc.ConnectTo(WordApp.Docum-ents.Add(EmptyParam, EmptyParam));

StopLoop:=False;

itxtStart:=0;

Memo.SelStart:=0;

itxtlen:=0;

whilenot StopLoop do

begin

itxtStart := itxtLen + itxtStart;

itxtLen := Pos(' ', Copy(Memo.Text,itxtStart+1,MaxInt));

if itxtLen = 0then

StopLoop := True;

Memo.SelStart := itxtStart;

Memo.SelLength := -1 + itxtLen;

if Memo.SelText = ''then

Continue;

Caption:=Memo.SelText;

WordDoc.Range.Delete(EmptyParam,Emp-tyParam);

WordDoc.Range.Set_Text(Memo.SelText);

colSpellErrors := WordDoc.SpellingErrors;

if colSpellErrors.Count <> 0then

begin

colSuggestions := WordApp.GetSpellingSuggestions

(colSpellErrors.Item(1).Get_Text);

with frSpellCheck do

begin

edNID.text := colSpellErrors.Item(1).Get_Text;

lbSuggestions.Items.Clear;

for i:= 1to colSuggestions.Count do

lbSuggestions.Items.Add(VarToStr-(colSuggestions.Item(i)));

lbSuggestions.ItemIndex := 0;

lbSuggestionsClick(Sender);

ShowModal;

case frSpellCheck.ModalResult of

mrAbort: Break;

mrIgnore: Continue;

mrOK:

if sReplacedWord <> ''then

begin

Memo.SelText := sReplacedWord;

itxtLen := Length(sReplacedWord);

end;

end;

end;

end;

end;

WordDoc.Disconnect;

varFalse:=False;

WordApp.Quit(varFalse);

Memo.SelStart := 0;

Memo.SelLength := 0;

end;

Code:

procedure TfrSpellCheck.lbSuggestionsClick(Sen-der: TObject);

begin

if lbSuggestions.ItemIndex <> -1then

edReplaceWith.Text := lbSuggestions.Items[lbSuggestio-ns.ItemIndex]

else

edReplaceWith.Text := '';

end;

procedure TfrSpellCheck.btnChangeClick(Sender: TObject);

begin

sReplacedWord := edReplaceWith.Text;

end;

procedure TfrSpellCheck.btnIgnoreClick(Sender: TObject);

begin

sReplacedWord := '';

end;

Code:

procedure TForm1.btnThesaurusClick(Sender: TObject);

var

varFalse : OleVariant;

begin

if Memo.SelText <> ''then

begin

WordApp.Connect;

WordDoc.ConnectTo(WordApp.Documen-ts.Add(EmptyParam, EmptyParam));

WordDoc.Range.Delete(EmptyParam,Empty-Param);

WordDoc.Range.Set_Text(Memo.SelText);

WordDoc.Range.CheckSynonyms;

Memo.SelText := WordDoc.Range.Get_Text;

WordDoc.Disconnect;

varFalse:=False;

WordApp.Quit(varFalse);

end;

end;

Code:

{ **** UBPFD *********** by delphibase.endimus.com ****

>> Небольшой модуль для работы со строками

function CompMask(S, Mask: string):string; //выбор строки по маске

// удаление из строки count символов начиная с posit

function deleteStr(s:string;posit,count:integer):string;

//Удаление из строки s сначала first и с конца last символов

function deleteFaskaStr(s:string; first,last:integer):string;

Запись в стринлист strg всех вхождений по маске mask из строки source

procedure getStrings(var strg: TStringList; mask,source: string);

Зависимости: classes,sysutils

Автор: SuMaga, Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра., ICQ:721602488, Махачкала

Copyright: Сам состряпал :)

Дата: 24 января 2003 г.

***************************************************** }

unit StrMask;

interface

uses classes, sysutils;

function CompMask(S, Mask: string): string;

function deleteStr(s: string; posit, count: integer): string;

function deleteFaskaStr(s: string; first, last: integer): string;

procedure getStrings(var strg: TStringList; mask, source: string);

implementation

type

TmaskObj = class

constructor open;

public

Maschr: tstringlist;

Masposish: TStringList;

destructor close;

end;

procedure getStrings(var strg: TStringList; mask, source: string);

var

s, s2: string;

begin

s2 := source;

s := CompMask(s2, mask);

while s <> ''do

begin

strg.Add(s);

s2 := StringReplace(s2, s, '', []);

s := CompMask(s2, mask);

if pos(s, s2) = 0then

break;

end;

end;

function eraseMask(inpstr: TStrings): TStrings;

var

i: integer;

e: boolean;

begin

e := false;

for i := 0to inpstr.Count - 1do

if (i <> inpstr.Count - 1) and (i < inpstr.Count - 1) then

if ((inpstr[i] = '`') and (inpstr[i + 1] = '|')) or

((inpstr[i] = '|') and (inpstr[i + 1] = '`')) or

((inpstr[i] = '`') and (inpstr[i + 1] = '`')) then

begin

e := true;

end;

if (e = false) or (i <= inpstr.Count - 1) then

begin

Result := inpstr;

exit;

end;

for i := 0to inpstr.Count - 1do

if (i <> inpstr.Count - 1) and (i < inpstr.Count - 1) then

if ((inpstr[i] = '`') and (inpstr[i + 1] = '|')) or

((inpstr[i] = '`') and (inpstr[i + 1] = '`')) or

((inpstr[i] = '|') and (inpstr[i + 1] = '`')) then

begin

inpstr.Delete(i + 1);

inpstr[i] := '`';

end;

Result := eraseMask(inpstr);

end;

{

`<---- Эквивалентна----->*

|<---- Эквивалентна----->?

}

function SplitMask(mask: string; MaskList: TStringList): TStringList;

var

i, j, k: integer;

s1: string;

mch: TmaskObj;

begin

mch := TmaskObj.open;

for i := 1to length(Mask) do

begin

if Mask[i] = '`'then

begin

mch.Maschr.Add('`');

mch.Masposish.Add(inttostr(i))

end;

if Mask[i] = '|'then

begin

mch.Maschr.Add('|');

mch.Masposish.Add(inttostr(i))

end;

end;

k := 0;

for i := 0to mch.Maschr.Count - 1do

begin

j := strtoint(mch.Masposish.Strings[i]) - k;

if j - 1 <> 0then

s1 := copy(Mask, 1, j - 1)

else

s1 := '';

delete(Mask, 1, j);

k := length(s1) + 1 + k;

if (s1 <> mch.Maschr.Strings[i]) and (length(s1) <> 0) then

MaskList.Add(s1);

MaskList.Add(mch.Maschr.Strings[i]);

end;

if Mask <> ''then

MaskList.Add(Mask);

mch.close;

Result := TStringList(eraseMask(MaskList));

end;

function deleteStr(s: string; posit, count: integer): string;

begin

Delete(s, posit, count);

Result := s;

end;

function deleteFaskaStr(s: string; first, last: integer): string;

begin

result := deleteStr(s, 1, first);

result := deleteStr(Result, length(Result) - last + 1, length(Result) -

(length(Result) - last));

end;

function CompMask(S, Mask: string): string;

var

i, j, k, y: integer;

s1, s2, s3, s4, s5: string;

MaskList: TStringList;

PrPos: integer;

var

fm: boolean;

label

1, 2, 3;

begin

2:

if length(s) = 0then

exit;

if length(Mask) = 0then

exit;

if length(s) < length(Mask) then

exit;

//if Assigned(MaskList) then

begin

MaskList := TStringList.Create;

MaskList := SplitMask(Mask, MaskList);

end;

PrPos := 0;

s4 := s;

fm := false;

s3 := '';

i := 0;

result := '';

if MaskList.Count - 1 = 0then

begin

if (MaskList[0] = '`') then

begin

s3 := s;

fm := true;

end;

if (MaskList[0] = '|') then

begin

s3 := s[1];

fm := true;

result := s3;

exit;

end;

if (MaskList[0] <> '`') and (MaskList[0] <> '|') then

begin

if pos(MaskList[0], s) = 0then

exit;

s3 := copy(s, pos(MaskList[0], s), length(MaskList[0]));

fm := true;

end;

i := MaskList.Count + 1;

end;

//Начало цикла

while i <= MaskList.Count - 1do

begin

if (MaskList[i] = '`') and (PrPos = 0) and (i + 1 <= MaskList.Count - 1)

then

begin

if pos(MaskList[i + 1], s) = 0then

goto2;

j := pos(MaskList[i + 1], s) + length(MaskList[i + 1]) - 1;

s3 := copy(s, 1, j);

delete(s, 1, j);

fm := true;

PrPos := j;

i := i + 1;

goto1;

end;

if (MaskList[i] = '|') and (PrPos = 0) and (i + 1 <= MaskList.Count - 1)

then

begin

k := i;

y := 0;

if i + 1 <= MaskList.Count - 1then

while (MaskList[k] = '|') do

begin

k := k + 1;

y := y + 1;

if k >= MaskList.Count - 1then

break;

end;

if pos(MaskList[k], s) = 0then

goto2;

j := pos(MaskList[k], s);

s3 := copy(s, j - y, length(MaskList[k]) + y);

delete(s, 1, j + length(MaskList[k]) - 1);

fm := true;

PrPos := j - 1;

i := k;

goto1;

end;

if (PrPos = 0) and (MaskList[i] <> '|') and (MaskList[i] <> '`') then

begin

if pos(MaskList[i], s) = 0then

break;

j := pos(MaskList[i], s);

s3 := copy(s, j, length(MaskList[i]));

delete(s, 1, j + length(MaskList[i]) - 1);