|
Syntax Highlighting with a Rich Edit
This code is kind of long and some things are left out.
It just gives and idea of how to do syntax highlighting
and certainly you would want to adapt much of it. There
are three kinds of situations handled by the listed
code. The first deals with loading an entire flie. It
basically reads in a file, adds RTF (Rich Text Format)
symbols to it, saves it to a file and then loads it
into a Rich Edit. The first three function deal with
this idea. The other two situations are color coding
the word at a given cursor position and color coding
specified lines of text.
This syntax highlighting is based on the idea that
different lines can be color coded independently, i.e.
it cannot color code things that span lines such as
block comments. Each line is parsed with functions and
data structures in the Reserved Words Unit.
Here are some of the variables and funcitons used in
the code, all of which are members of MainForm:
Edit : TRichEdit
LangWordsList : TLangReservedWordsList//from the Reserved Words Unit
//if > 0 then no color coding happens. Used to temporarely turn it off.
PuaseColorCoding : integer
//saves and restores Edit's SelStart, SelLength, and the Scroll Position
procedure(s) Save/LoadEditAttributes
//calls Save/LoadEditAttributes and does Modified as well
procedure(s) Save/LoadAllEditAttributes
//does color coding for an entire file
procedure TMainForm.ColorCodeFromStringList(strList : TStringList);
function MakeColorTableEntry(color : TColor) : string;
var
long : LongInt;
r, g, b : byte;
begin
long := ColorToRGB(color);
r := long mod $100;
long := long div $100;
g := long mod $100;
long := long div $100;
b := long mod $100;
result := '\red' + IntToStr(r) + '\green' + IntToStr(g) + '\blue' + IntToStr(b) + ';';
end;
//in RTF the symbols {, }, and / are preceded by a /
procedure FixRTFSymbols(var str : string);
var i, len : integer;
begin
len := length(str);
i := 1;
while i <= len do begin
if (str[i] = '{') or (str[i] = '}') or (str[i] = '\') then begin
System.Insert('\', str, i);
inc(len);
inc(i);
end;
inc(i);
end;
end;
var
i, j : integer;
str1, str2 : string;
begin
if (PauseColorCoding > 0) or
not ColorCodingAvaliable then
with Edit do begin
SetRedraw(false);
//to make new text the color of DefAttributes
SelStart := 0; SelLength := 1;
SelAttributes := DefAttributes;
SetRedraw(true);
Text := strList.Text;
exit;
end;
if strList.Count > 0 then
for j := 0 to strList.Count - 1 do
with LangWordsList do
with Parses do begin
ParseLine(strList[j]);
str1 := '';
for i := 0 to Items.Count - 1 do begin
case Items[i]^.Kind of
tkPlainText : str1 := str1 + '\cf0 ';
tkSymbol : str1 := str1 + '\cf1 ';
tkKeyWord : str1 := str1 + '\cf2 ';
end;
str2 := copy(strList[j], Items[i].Start, Items[i].Length);
FixRTFSymbols(str2);
str1 := str1 + str2;
end;
if j > 0 then str1 := '\par ' + str1;
strList[j] := str1;
end;
strList.Insert(0, '{\rtf1\ansi\ansicpg1252\deff0\deftab720{\fonttbl{\f0\fmodern\fcharset1 ' + Edit.Font.Name + ';}}');
{color table must contain colors for plain text, symbols,
and key words IN THAT ORDER}
strList.Insert(1, '{\colortbl' + MakeColorTableEntry(Edit.Font.Color) + MakeColorTableEntry(LangWordsList.SymbolsColor) + MakeColorTableEntry(LangWordsList.KeyWordsColor) + '}');
strList.Insert(2, '\deflang1033\pard\plain\f0\fs' + IntToStr(2*Edit.Font.Size));
//RTF files end with a }
strList.Add('}');
strList.SaveToFile(SourceDir + FN_TEMP_RTF);
Edit.PlainText := false;
inc(PauseColorCoding);
Edit.Lines.LoadFromFile(SourceDir + FN_TEMP_RTF);
dec(PauseColorCoding);
Edit.PlainText := true;
end;
procedure TMainForm.LoadAndColorCode(const fName : TFileName);
var strList : TStringList;
begin
strList := TStringList.Create;
strList.LoadFromFile(fName);
ColorCodeFromStringList(strList);
strList.Free;
end;
procedure TMainForm.AssignAndColorCode(const str : string);
var strList : TStringList;
begin
strList := TStringList.Create;
strList.Text := str;
ColorCodeFromStringList(strList);
strList.Free;
end;
procedure TMainForm.InvalidateChars(pos : integer);
var
rect : TRect;
point : TPoint;
begin
with Edit do begin
Perform(EM_POSFROMCHAR, LongInt(@point), pos);
rect.Top := point.y; rect.Left := point.x;
pos := Perform(EM_LINEFROMCHAR, pos, 0) + 1;
if pos >= Lines.Count then
rect.Bottom := Height
else begin
pos := Perform(EM_LINEINDEX, pos, 0);
Perform(EM_POSFROMCHAR, LongInt(@point), pos);
rect.Bottom := point.y;
end;
rect.Right := Width;
InvalidateRect(Handle, @rect, true);
end;
end;
procedure TMainForm.ColorCodeWord(caretPos : integer);
var j, start, stop : integer;
begin
if (PauseColorCoding > 0) or not ColorCodingAvaliable then exit;
assert(caretPos > 0);
assert(caretPos <= Edit.GetTextLen);
{to prevent this function from calling itself
through EditChange}
inc(PauseColorCoding);
with Edit do begin
SetRedraw(false);
SaveAllEditAttributes;
start := caretPos; stop := caretPos;
while (start > 1) and not IsWhiteSpace(Text[start - 1]) do
dec(start);
while (stop < GetTextLen) and not IsWhiteSpace(Text[stop + 1]) do
inc(stop);
with LangWordsList do
with Parses do begin
ParseLine(copy(Text, start, stop - start + 1));
if Items.Count > 0 then
for j := 0 to Items.Count - 1 do begin
//- 1 since Items[x].Start is 1 based
SelStart := start - 1 + Items[j].Start - 1;
SelLength := Items[j].Length;
case Items[j].Kind of
tkPlainText : if not (caColor in SelAttributes.ConsistentAttributes) or (SelAttributes.Color <> DefAttributes.Color) then SelAttributes.Color := DefAttributes.Color;
tkSymbol : if not (caColor in SelAttributes.ConsistentAttributes) or (SelAttributes.Color <> SymbolsColor) then SelAttributes.Color := SymbolsColor;
tkKeyWord : if not (caColor in SelAttributes.ConsistentAttributes) or (SelAttributes.Color <> KeyWordsColor) then SelAttributes.Color := KeyWordsColor;
end;
end;
end;
LoadAllEditAttributes;
SetRedraw(true);
InvalidateChars(max(Perform(EM_LINEINDEX, Perform(EM_LINEFROMCHAR, start, 0), 0), start - 1));
dec(PauseColorCoding);
end;//with Edit
end;
procedure TMainForm.InvalidateLines(start, stop : integer);
var
rect : TRect;
point : TPoint;
begin
with Edit do begin
start := Perform(EM_LINEINDEX, start, 0);
Perform(EM_POSFROMCHAR, LongInt(@point), start);
rect.Top := point.y;
stop := Perform(EM_LINEINDEX, stop + 1, 0);
Perform(EM_POSFROMCHAR, LongInt(@point), stop);
rect.Bottom := point.y;
rect.Left := 0;
rect.Right := Width;
InvalidateRect(Handle, @rect, true);
end;
end;
procedure TMainForm.ColorCodeLines(start, stop : integer; DoInvalidate : boolean);
var i, j, lineIndex : integer;
begin
if (PauseColorCoding > 0) or not ColorCodingAvaliable then exit;
assert(start <= stop);
assert(start >= 0);
assert(stop <= Edit.Lines.Count);
if (stop - start > 30) then begin
ColorCodeAll;
exit;
end;
with Edit do begin
if start = Lines.Count - 1 then dec(start);
if stop = Lines.Count - 1 then dec(stop);
if stop < 0 then exit;
{to prevent this function from calling itself
through EditChange}
inc(PauseColorCoding);
SetRedraw(false);
SaveAllEditAttributes;
with LangWordsList do
for i := start to stop do
with Parses do begin
ParseLine(Lines[i]);
//- 1 since Items[x].Start is 1 based
lineIndex := Perform(EM_LINEINDEX, i, 0) - 1;
if Items.Count > 0 then
for j := 0 to Items.Count - 1 do begin
SelStart := lineIndex + Items[j].Start;
SelLength := Items[j].Length;
case Items[j].Kind of
tkPlainText : if not (caColor in SelAttributes.ConsistentAttributes) or (SelAttributes.Color <> DefAttributes.Color) then SelAttributes.Color := DefAttributes.Color;
tkSymbol : if not (caColor in SelAttributes.ConsistentAttributes) or (SelAttributes.Color <> SymbolsColor) then SelAttributes.Color := SymbolsColor;
tkKeyWord : if not (caColor in SelAttributes.ConsistentAttributes) or (SelAttributes.Color <> KeyWordsColor) then SelAttributes.Color := KeyWordsColor;
end;
end;
end;
LoadAllEditAttributes;
SetRedraw(true);
if DoInvalidate then InvalidateLines(start, stop);
dec(PauseColorCoding);
end;//with Edit
end;
|