FUNCTION MarkTexts(RE:TRichEdit;
const S:
String; ATextKind:TTextKind=tkText;
AIgnoreCase:Boolean=True; AMarkCount:Integer=0;
AMarkStyles:TMarkStyles=[msBold,msColor]; AColor:TColor=clRed):Integer;
type
TFoundRec=Record Pos,Last:Integer;
end;
TFound=Array
of TFoundRec;
TPFoundRec=^TFoundRec;
TFSI=Array
of TPFoundRec;
var
Count,ActCount:Integer; SearchFor,SearchIn:
String; Found:TFound; FSI:TFSI;
//------------------------------------------------------------------------------
FUNCTION GetTexts:Boolean;
var I,J:Integer;
begin
if S='
'
then Exit(False);
if AIgnoreCase
then SearchFor:=AnsiUpperCase(S)
else SearchFor:=S;
SearchIn:=RE.Text;
J:=0;
for I:=1
to Length(SearchIn)
do
if SearchIn[I]<>#10
then begin
Inc(J);
SearchIn[J]:=SearchIn[I];
end;
if J<Length(SearchFor)
then Exit(False);
SetLength(SearchIn,J);
if AIgnoreCase
then SearchIn:=AnsiUpperCase(SearchIn);
Result:=True;
end;
//------------------------------------------------------------------------------
FUNCTION Add(APos,ALen:Integer):Boolean;
var I,Len:Integer; NewRec:TFoundRec;
begin
NewRec.Pos:=APos;
NewRec.Last:=APos+ALen-1;
if (AMarkCount<0)
and (ActCount=Abs(AMarkCount))
then begin
for I:=Count-ActCount
to Count-2
do Found[I]:=Found[I+1];
Found[Count-1]:=NewRec;
Result:=True;
end else begin
Len:=Length(Found);
if Len<=Count
then SetLength(Found,Len+100);
Found[Count]:=NewRec;
Inc(Count);
Inc(ActCount);
Result:=(AMarkCount<=0)
or (ActCount<AMarkCount);
end;
end;
//------------------------------------------------------------------------------
PROCEDURE FindText(
const S:
String);
var Len,P:Integer;
begin
if S<>'
'
then begin
ActCount:=0;
Len:=Length(S);
P:=1;
repeat
P:=PosEx(S,SearchIn,P);
if P=0
then Exit;
if not Add(P,Len)
then Exit;
P:=P+Len;
until False;
end;
end;
//------------------------------------------------------------------------------
PROCEDURE FindTexts(
const S:
String);
var P,LastP,Len:Integer;
begin
LastP:=1;
repeat
P:=PosEx('
,',S,LastP);
if P=0
then Len:=MaxInt
else Len:=P-LastP;
FindText(Trim(Copy(S,LastP,Len)));
LastP:=P+1;
until P=0;
end;
//------------------------------------------------------------------------------
PROCEDURE FindWord(
const S:
String);
var Len,P,SILen:Integer; IsWord:Boolean;
//---------------------------------------------------------
FUNCTION WordFound:Boolean;
begin
case ATextKind
of
tkWords:
Result:=((P=1)
or not IsCharAlpha(SearchIn[P-1]))
and
((P+Len>SILen)
or not IsCharAlpha(SearchIn[P+Len]));
tkWordsBegin:
Result:=(P=1)
or not IsCharAlpha(SearchIn[P-1]);
tkWordsEnd:
Result:=(P+Len>SILen)
or not IsCharAlpha(SearchIn[P+Len]);
tkWordsContain:
Result:=True;
end;
end;
//---------------------------------------------------------
begin
if S<>'
'
then begin
SILen:=Length(SearchIn);
Len:=Length(S);
ActCount:=0;
P:=1;
repeat
P:=PosEx(S,SearchIn,P);
if P=0
then Exit;
if WordFound
then
if not Add(P,Len)
then Exit;
P:=P+Len;
until False;
end;
end;
//------------------------------------------------------------------------------
PROCEDURE FindWords(
const S:
String);
var PAct,PFirst,PStart:PChar;
begin
PFirst:=PChar(S);
PAct:=PFirst;
while PAct^<>#0
do
if IsCharAlpha(PAct^)
then begin
PStart:=PAct;
Inc(PAct);
while IsCharAlpha(PAct^)
do Inc(PAct);
FindWord(Copy(S,PStart-PFirst+1,PAct-PStart));
end else begin
Inc(PAct);
end;
end;
//------------------------------------------------------------------------------
PROCEDURE SortFound;
var M,H:TPFoundRec;
//---------------------------------------------------------
FUNCTION Compare(A:TPFoundRec):Integer;
begin
Result:=A.Pos-M.Pos;
if Result=0
then Result:=A.Last-M.Last;
end;
//---------------------------------------------------------
PROCEDURE QSort(First,Last:Integer);
var I,J:Integer;
begin
I:=First;
J:=Last;
M:=FSI[(First+Last)
shr 1];
repeat
while Compare(FSI[I])<0
do Inc(I);
while Compare(FSI[J])>0
do Dec(J);
if I<=J
then begin
H:=FSI[I];
FSI[I]:=FSI[J];
FSI[J]:=H;
Inc(I);
Dec(J);
end;
until I>J;
if J>First
then QSort(First,J);
if I<Last
then QSort(I,Last);
end;
//---------------------------------------------------------
begin
if (Length(FSI)>1)
then QSort(0,High(FSI));
end;
//------------------------------------------------------------------------------
FUNCTION Overlaps(A,B:TPFoundRec):Boolean;
begin
Result:=(A.Pos=B.Pos)
or
(A.Pos<B.Pos)
and (A.Last>=B.Pos)
or
(A.Pos>B.Pos)
and (A.Pos<=B.Last);
if Result
then begin
A.Pos:=Min(A.Pos,B.Pos);
A.Last:=Max(A.Last,B.Last);
end;
end;
//------------------------------------------------------------------------------
FUNCTION ConsolidateFound:Integer;
var I,J,Last:Integer;
begin
SetLength(FSI,Count);
for I:=0
to Count-1
do FSI[I]:=@Found[I];
SortFound;
Last:=High(FSI);
I:=0;
if Last>0
then
while I<Last
do
if Overlaps(FSI[I],FSI[I+1])
then begin
for J:=I+1
to Last-1
do FSI[J]:=FSI[J+1];
Dec(Last);
end else begin
Inc(I);
end;
Result:=Last;
end;
//------------------------------------------------------------------------------
var I,J,Last:Integer; NewStyle:TFontStyles; HasColor:Boolean;
begin
Result:=0;
if AMarkStyles=[]
then Exit;
if not GetTexts
then Exit;
Count:=0;
case ATextKind
of
tkText : FindText(SearchFor);
tkTexts : FindTexts(SearchFor);
else FindWords(SearchFor);
end;
if Count=0
then Exit;
HasColor:=msColor
in AMarkStyles;
NewStyle:=TFontStyles(AMarkStyles*[msBold,msItalic,msUnderline,msStrikeOut]);
Last:=ConsolidateFound;
for I:=0
to Last
do
with RE, FSI[I]^
do begin
SelStart:=Pos-1;
SelLength:=Last-Pos+1;
SelAttributes.Style:=NewStyle;
if HasColor
then SelAttributes.Color:=AColor;
end;
Result:=Last+1;
end;