{******************************************} { } { FastReport v4.0 } { Syntax memo control } { } { Copyright (c) 1998-2008 } { by Alexander Tzyganenko, } { Fast Reports Inc. } { } {******************************************} unit frxSynMemo; interface {$I frx.inc} uses Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls, Forms, frxCtrls, fs_iparser, frxPopupForm, Imm {$IFDEF DELPHI19} , FMX.Graphics {$ENDIF}; type TCharAttr = (caNo, caText, caBlock, caComment, caKeyword, caString, caNumber); TCharAttributes = set of TCharAttr; TfrxCodeCompletionEvent = procedure(const Name: String; List: TStrings) of object; TfrxSyntaxMemo = class(TfrxScrollWin) private FActiveLine: Integer; FAllowLinesChange: Boolean; FBlockColor: TColor; FBlockFontColor: TColor; FBookmarks: array[0..9] of Integer; FCharHeight: Integer; FCharWidth: Integer; FCommentAttr: TFont; FCompletionForm: TfrxPopupForm; FCompletionLB: TListBox; FDoubleClicked: Boolean; FDown: Boolean; FToggleBreakPointDown: Boolean; FGutterWidth: Integer; FIsMonoType: Boolean; FKeywordAttr: TFont; FMaxLength: Integer; FMessage: String; FModified: Boolean; FMoved: Boolean; FNumberAttr: TFont; FOffset: TPoint; FOnChangePos: TNotifyEvent; FOnChangeText: TNotifyEvent; FOnCodeCompletion: TfrxCodeCompletionEvent; FParser: TfsParser; FPos: TPoint; FStringAttr: TFont; FSelEnd: TPoint; FSelStart: TPoint; FCompSelStart: TPoint; FCompSelEnd: TPoint; FShowGutter: boolean; FSynStrings: TStrings; FSyntax: String; FTempPos: TPoint; FText: TStringList; FTextAttr: TFont; FUndo: TStringList; FUpdatingSyntax: Boolean; FWindowSize: TPoint; FBreakPoints: TStringList; FTmpCanvas: TBitmap; { need for east languages carret correction } function GetCharWidth(Str: String): Integer; function GetCharAttr(Pos: TPoint): TCharAttributes; function GetLineBegin(Index: Integer): Integer; function GetPlainTextPos(Pos: TPoint): Integer; function GetPosPlainText(Pos: Integer): TPoint; function GetRunLine(Index: Integer): Boolean; function GetSelText: String; function GetText: TStrings; function LineAt(Index: Integer): String; function LineLength(Index: Integer): Integer; function Pad(n: Integer): String; procedure AddSel; procedure AddUndo; procedure ClearSel; procedure ClearSyntax(ClearFrom: Integer); procedure CompletionLBDblClick(Sender: TObject); procedure CompletionLBDrawItem(Control: TWinControl; Index: Integer; ARect: TRect; State: TOwnerDrawState); procedure CompletionLBKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure CorrectBookmark(Line, Delta: Integer); procedure CorrectBreakPoints(Line, Delta: Integer); procedure CreateSynArray(EndLine: Integer); procedure DoBackspace; procedure DoChange; procedure DoChar(Ch: Char); procedure DoCodeCompletion; procedure DoCtrlI; procedure DoCtrlU; procedure DoCtrlR; procedure DoCtrlL; procedure DoDel; procedure DoDown; procedure DoEnd(Ctrl: Boolean); procedure DoHome(Ctrl: Boolean); procedure DoLeft; procedure DoPgUp; procedure DoPgDn; procedure DoReturn; procedure DoRight; procedure DoUp; procedure EnterIndent; procedure LinesChange(Sender: TObject); procedure SetActiveLine(Line: Integer); procedure SetCommentAttr(Value: TFont); procedure SetKeywordAttr(Value: TFont); procedure SetNumberAttr(const Value: TFont); procedure SetRunLine(Index: Integer; const Value: Boolean); procedure SetSelText(const Value: String); procedure SetShowGutter(Value: Boolean); procedure SetStringAttr(Value: TFont); procedure SetSyntax(const Value: String); procedure SetText(Value: TStrings); procedure SetTextAttr(Value: TFont); procedure ShiftSelected(ShiftRight: Boolean); procedure ShowCaretPos; procedure TabIndent; procedure UnIndent; procedure UpdateScrollBar; procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS; procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; { Inline IME realisation } procedure WMIMEStartComp(var Message: TMessage); message WM_IME_STARTCOMPOSITION; procedure WMIMEEndComp(var Message: TMessage); message WM_IME_ENDCOMPOSITION; procedure WMIMECOMPOSITION (var Message: TMessage); message WM_IME_COMPOSITION ; function GetTextSelected: Boolean; protected procedure DblClick; override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyPress(var Key: Char); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure MouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure OnHScrollChange(Sender: TObject); override; procedure OnVScrollChange(Sender: TObject); override; procedure Resize; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Paint; override; procedure CopyToClipboard; procedure CutToClipboard; procedure PasteFromClipboard; procedure SelectAll; procedure SetPos(x, y: Integer); procedure ShowMessage(const s: String); procedure Undo; procedure UpdateView; function Find(const SearchText: String; CaseSensitive: Boolean; var SearchFrom: Integer): Boolean; function GetPlainPos: Integer; function GetPos: TPoint; function IsBookmark(Line: Integer): Integer; procedure AddBookmark(Line, Number: Integer); procedure DeleteBookmark(Number: Integer); procedure GotoBookmark(Number: Integer); procedure AddBreakPoint(Number: Integer; const Condition: String); procedure ToggleBreakPoint(Number: Integer; const Condition: String); procedure DeleteBreakPoint(Number: Integer); procedure DeleteF4BreakPoints; function IsBreakPoint(Number: Integer): Boolean; function GetBreakPointCondition(Number: Integer): String; property ActiveLine: Integer read FActiveLine write SetActiveLine; property BlockColor: TColor read FBlockColor write FBlockColor; property BlockFontColor: TColor read FBlockFontColor write FBlockFontColor; property BreakPoints: TStringList read FBreakPoints; property Color; property CommentAttr: TFont read FCommentAttr write SetCommentAttr; property Font; property ImeMode; property ImeName; property GutterWidth: Integer read FGutterWidth write FGutterWidth; property KeywordAttr: TFont read FKeywordAttr write SetKeywordAttr; property Modified: Boolean read FModified write FModified; property NumberAttr: TFont read FNumberAttr write SetNumberAttr; property RunLine[Index: Integer]: Boolean read GetRunLine write SetRunLine; property SelText: String read GetSelText write SetSelText; property StringAttr: TFont read FStringAttr write SetStringAttr; property TextAttr: TFont read FTextAttr write SetTextAttr; property Lines: TStrings read GetText write SetText; property Syntax: String read FSyntax write SetSyntax; property ShowGutter: boolean read FShowGutter write SetShowGutter; property TextSelected: Boolean read GetTextSelected; property OnChangePos: TNotifyEvent read FOnChangePos write FOnChangePos; property OnChangeText: TNotifyEvent read FOnChangeText write FOnChangeText; property OnCodeCompletion: TfrxCodeCompletionEvent read FOnCodeCompletion write FOnCodeCompletion; property OnDragDrop; property OnDragOver; property OnKeyDown; end; implementation uses Clipbrd, fs_itools, frxXML; const SQLKeywords = 'active,after,all,alter,and,any,as,asc,ascending,at,auto,' + 'base_name,before,begin,between,by,cache,call,cast,check,column,commit,' + 'committed,computed,conditional,constraint,containing,count,create,' + 'current,cursor,database,debug,declare,default,delete,desc,descending,' + 'distinct,do,domain,drop,else,end,entry_point,escape,exception,execute,' + 'exists,exit,external,extract,filter,for,foreign,from,full,function,' + 'generator,grant,group,having,if,in,inactive,index,inner,insert,into,is,' + 'isolation,join,key,left,level,like,merge,names,no,not,null,of,on,only,' + 'or,order,outer,parameter,password,plan,position,primary,privileges,' + 'procedure,protected,read,retain,returns,revoke,right,rollback,schema,' + 'select,set,shadow,shared,snapshot,some,suspend,table,then,to,' + 'transaction,trigger,uncommitted,union,unique,update,user,using,values,' + 'view,wait,when,where,while,with,work'; WordChars = ['a'..'z', 'A'..'Z', 'à'..'ÿ', 'À'..'ß', '0'..'9', '_']; function IsUnicodeChar(Chr: Char): Boolean; begin Result := ((Chr >= Char($007F)) and (Chr <= Char($FFFF))); end; { TfrxSyntaxMemo } constructor TfrxSyntaxMemo.Create(AOwner: TComponent); var i: Integer; begin inherited; FTmpCanvas := TBitmap.Create; DoubleBuffered := True; TabStop := True; Cursor := crIBeam; Color := clWindow; FBreakPoints := TStringList.Create; FBlockColor := clHighlight; FBlockFontColor := clHighlightText; FCommentAttr := TFont.Create; FCommentAttr.Color := clNavy; FCommentAttr.Style := [fsItalic]; FKeywordAttr := TFont.Create; FKeywordAttr.Color := clWindowText; FKeywordAttr.Style := [fsBold]; FNumberAttr := TFont.Create; FNumberAttr.Color := clGreen; FNumberAttr.Style := []; FStringAttr := TFont.Create; FStringAttr.Color := clNavy; FStringAttr.Style := []; FTextAttr := TFont.Create; FTextAttr.Color := clWindowText; FTextAttr.Style := []; Font.Size := 10; Font.Name := 'Courier New'; FText := TStringList.Create; FParser := TfsParser.Create; FParser.SkipSpace := False; FParser.UseY := False; FSynStrings := TStringList.Create; FUndo := TStringList.Create; FText.Add(''); FText.OnChange := LinesChange; FMaxLength := 1024; FMoved := True; SetPos(1, 1); ShowGutter := True; OnMouseWheelUp := MouseWheelUp; OnMouseWheelDown := MouseWheelDown; FActiveLine := -1; for i := 0 to 9 do FBookmarks[i] := -1; end; destructor TfrxSyntaxMemo.Destroy; begin FTmpCanvas.Free; FBreakPoints.Free; FCommentAttr.Free; FKeywordAttr.Free; FNumberAttr.Free; FStringAttr.Free; FTextAttr.Free; FText.Free; FUndo.Free; FSynStrings.Free; FParser.Free; inherited; end; { updating IME string and carret pos } procedure TfrxSyntaxMemo.WMIMECOMPOSITION(var Message: TMessage); var h: HIMC; nLen, nPos: Integer; StrBuf: String; begin if Message.LParam = $1E00 then ResetImeComposition(CPS_CANCEL) else begin h := Imm32GetContext(Handle); if h <> 0 then begin nPos := Imm32GetCompositionString(h, GCS_CURSORPOS, nil, 0); nLen := Imm32GetCompositionString(h, GCS_COMPSTR, nil, 0); if nLen <> 0 then begin SetLength(StrBuf, nLen div 2); Imm32GetCompositionString(h, GCS_COMPSTR, @StrBuf[1], nLen); if (nLen div 2) > FCompSelEnd.X - FCompSelStart.X then FCompSelEnd.X := FCompSelStart.X + (nLen div 2) - 1; FSelStart.Y := FCompSelStart.Y; FSelStart.X := FCompSelStart.X; FSelEnd.Y := FCompSelEnd.Y; FSelEnd.X := FCompSelEnd.X; SelText := StrBuf; FPos.X := FCompSelStart.X + nPos; SetPos(FPos.X, FPos.Y); FCompSelEnd.X := FCompSelStart.X + (nLen div 2); Invalidate; end; Imm32ReleaseContext(Handle, h); end; Inherited; end; end; procedure TfrxSyntaxMemo.WMIMEEndComp(var Message: TMessage); begin FInImeComposition := False; end; procedure TfrxSyntaxMemo.WMIMEStartComp(var Message: TMessage); begin FCompSelStart.Y := FPos.Y; FCompSelStart.X := FPos.X; FCompSelEnd.Y := FPos.Y; FCompSelEnd.X := FPos.X; FInImeComposition := True; end; procedure TfrxSyntaxMemo.WMKillFocus(var Msg: TWMKillFocus); begin inherited; HideCaret(Handle); DestroyCaret; end; procedure TfrxSyntaxMemo.WMSetFocus(var Msg: TWMSetFocus); begin inherited; CreateCaret(Handle, 0, 2, FCharHeight); ShowCaretPos; end; procedure TfrxSyntaxMemo.ShowCaretPos; var cWidth: Integer; begin if FPos.X > FOffset.X then begin if Length(Lines[FPos.Y - 1]) > FPos.X then cWidth := GetCharWidth(Copy(Lines[FPos.Y - 1], 1, FPos.X - 1 - FOffset.X)) else cWidth := FCharWidth * (FPos.X - 1 - FOffset.X); SetCaretPos(cWidth + FGutterWidth, FCharHeight * (FPos.Y - 1 - FOffset.Y)); ShowCaret(Handle); end else SetCaretPos(-100, -100); if Assigned(FOnChangePos) then FOnChangePos(Self); end; procedure TfrxSyntaxMemo.CMFontChanged(var Message: TMessage); var b: TBitmap; begin FCommentAttr.Size := Font.Size; FCommentAttr.Name := Font.Name; FKeywordAttr.Size := Font.Size; FKeywordAttr.Name := Font.Name; FNumberAttr.Size := Font.Size; FNumberAttr.Name := Font.Name; FStringAttr.Size := Font.Size; FStringAttr.Name := Font.Name; FTextAttr.Size := Font.Size; FTextAttr.Name := Font.Name; b := TBitmap.Create; with b.Canvas do begin Font.Assign(Self.Font); Font.Style := [fsBold]; FCharHeight := TextHeight('Wg') + 1; FCharWidth := TextWidth('W'); FIsMonoType := Pos('COURIER NEW', AnsiUppercase(Self.Font.Name)) <> 0; end; b.Free; end; procedure TfrxSyntaxMemo.Resize; begin inherited; if FCharWidth = 0 then Exit; FWindowSize := Point((ClientWidth - FGutterWidth) div FCharWidth, ClientHeight div FCharHeight); HorzPage := FWindowSize.X; VertPage := FWindowSize.Y; UpdateScrollBar; end; procedure TfrxSyntaxMemo.UpdateScrollBar; begin VertRange := FText.Count; HorzRange := FMaxLength; LargeChange := FWindowSize.Y; VertPosition := FOffset.Y; HorzPosition := FOffset.X; end; function TfrxSyntaxMemo.GetText: TStrings; //var // i: Integer; begin // FAllowLinesChange := False; // for i := 0 to FText.Count - 1 do // FText[i] := LineAt(i); Result := FText; FAllowLinesChange := True; end; function TfrxSyntaxMemo.GetPlainPos: Integer; begin Result := GetPlainTextPos(FPos); end; function TfrxSyntaxMemo.GetPos: TPoint; begin Result := FPos; end; procedure TfrxSyntaxMemo.SetText(Value: TStrings); begin FAllowLinesChange := True; FText.Assign(Value); end; procedure TfrxSyntaxMemo.SetSyntax(const Value: String); var sl: TStringList; procedure GetGrammar; var Grammar: TfrxXMLDocument; ss: TStringStream; ParserRoot, xi: TfrxXMLItem; i: Integer; Name, PropText: String; begin Grammar := TfrxXMLDocument.Create; ss := TStringStream.Create(fsGetLanguage(Value), TEncoding.UTF8); Grammar.LoadFromStream(ss); ss.Free; ParserRoot := Grammar.Root.FindItem('parser'); xi := ParserRoot.FindItem('keywords'); for i := 0 to xi.Count - 1 do FParser.Keywords.Add(xi[i].Name); for i := 0 to ParserRoot.Count - 1 do begin Name := LowerCase(ParserRoot[i].Name); PropText := ParserRoot[i].Prop['text']; if Name = 'identchars' then FParser.ConstructCharset(PropText) else if Name = 'commentline1' then FParser.CommentLine1 := PropText else if Name = 'commentline2' then FParser.CommentLine2 := PropText else if Name = 'commentblock1' then FParser.CommentBlock1 := PropText else if Name = 'commentblock2' then FParser.CommentBlock2 := PropText else if Name = 'stringquotes' then FParser.StringQuotes := PropText else if Name = 'hexsequence' then FParser.HexSequence := PropText end; Grammar.Free; end; begin FSyntax := Value; FParser.Keywords.Clear; sl := TStringList.Create; if AnsiCompareText(Value, 'SQL') = 0 then begin sl.CommaText := SQLKeywords; FParser.Keywords.Assign(sl); FParser.CommentLine1 := '--'; FParser.CommentLine2 := ''; FParser.CommentBlock1 := '/*,*/'; FParser.CommentBlock2 := ''; FParser.StringQuotes := '"'; FParser.HexSequence := '0x'; end else begin fsGetLanguageList(sl); if sl.IndexOf(Value) <> -1 then GetGrammar; end; ClearSyntax(1); sl.Free; end; procedure TfrxSyntaxMemo.SetCommentAttr(Value: TFont); begin FCommentAttr.Assign(Value); Repaint; end; procedure TfrxSyntaxMemo.SetKeywordAttr(Value: TFont); begin FKeywordAttr.Assign(Value); Repaint; end; procedure TfrxSyntaxMemo.SetNumberAttr(const Value: TFont); begin FNumberAttr.Assign(Value); Repaint; end; procedure TfrxSyntaxMemo.SetStringAttr(Value: TFont); begin FStringAttr.Assign(Value); Repaint; end; procedure TfrxSyntaxMemo.SetTextAttr(Value: TFont); begin FTextAttr.Assign(Value); Repaint; end; procedure TfrxSyntaxMemo.SetActiveLine(Line: Integer); begin FActiveLine := Line; Repaint; end; procedure TfrxSyntaxMemo.DoChange; begin FModified := True; if Assigned(FOnChangeText) then FOnChangeText(Self); end; procedure TfrxSyntaxMemo.LinesChange(Sender: TObject); begin if FAllowLinesChange then begin FAllowLinesChange := False; if FText.Count = 0 then FText.Add(''); ClearSyntax(1); FMoved := True; FUndo.Clear; FPos := Point(1, 1); FOffset := Point(0, 0); ClearSel; ShowCaretPos; UpdateScrollBar; end; end; procedure TfrxSyntaxMemo.ShowMessage(const s: String); begin FMessage := s; Repaint; end; procedure TfrxSyntaxMemo.CopyToClipboard; begin if FSelStart.X <> 0 then Clipboard.AsText := SelText; end; procedure TfrxSyntaxMemo.CutToClipboard; begin if FSelStart.X <> 0 then begin Clipboard.AsText := SelText; SelText := ''; end; CorrectBookmark(FSelStart.Y, FSelStart.Y - FSelEnd.Y); Repaint; end; procedure TfrxSyntaxMemo.PasteFromClipboard; begin SelText := Clipboard.AsText; end; procedure TfrxSyntaxMemo.SelectAll; begin SetPos(0, 0); FSelStart := FPos; SetPos(LineLength(FText.Count - 1) + 1, FText.Count); FSelEnd := FPos; Repaint; end; function TfrxSyntaxMemo.LineAt(Index: Integer): String; begin if Index < FText.Count then Result := TrimRight(FText[Index]) else Result := ''; end; function TfrxSyntaxMemo.LineLength(Index: Integer): Integer; begin Result := Length(LineAt(Index)); end; function TfrxSyntaxMemo.Pad(n: Integer): String; begin Result := ''; SetLength(Result, n); Result := StringOfChar(Char(' '), n); end; procedure TfrxSyntaxMemo.AddUndo; begin if not FMoved then exit; FUndo.Add(Format('%5d%5d', [FPos.X, FPos.Y]) + FText.Text); if FUndo.Count > 32 then FUndo.Delete(0); FMoved := False; end; procedure TfrxSyntaxMemo.Undo; var s: String; begin FMoved := True; if FUndo.Count = 0 then exit; s := FUndo[FUndo.Count - 1]; FPos.X := StrToInt(Copy(s, 1, 5)); FPos.Y := StrToInt(Copy(s, 6, 5)); FAllowLinesChange := False; FText.Text := Copy(s, 11, Length(s) - 10); FAllowLinesChange := True; FUndo.Delete(FUndo.Count - 1); SetPos(FPos.X, FPos.Y); ClearSyntax(1); DoChange; end; function TfrxSyntaxMemo.GetPlainTextPos(Pos: TPoint): Integer; var i: Integer; begin Result := 0; for i := 0 to Pos.Y - 2 do Result := Result + Length(FText[i]) + 2; Result := Result + Pos.X; end; function TfrxSyntaxMemo.GetPosPlainText(Pos: Integer): TPoint; var i: Integer; s: String; begin Result := Point(0, 1); s := FText.Text; i := 1; while i <= Pos do if s[i] = #13 then begin Inc(i, 2); if i <= Pos then begin Inc(Result.Y); Result.X := 0; end else Inc(Result.X); end else begin Inc(i); Inc(Result.X); end; end; function TfrxSyntaxMemo.GetLineBegin(Index: Integer): Integer; var s: String; begin s := FText[Index]; Result := 1; if Trim(s) <> '' then for Result := 1 to Length(s) do if s[Result] <> ' ' then break; end; procedure TfrxSyntaxMemo.TabIndent; begin SelText := Pad((FPos.X div 8 + 1) * 8 - FPos.X); end; procedure TfrxSyntaxMemo.EnterIndent; var res: Integer; begin if Trim(FText[FPos.Y - 1]) = '' then res := FPos.X else res := GetLineBegin(FPos.Y - 1); if FPos.X = 1 then CorrectBookmark(FPos.Y - 1, 1) else CorrectBookmark(FPos.Y, 1); FPos := Point(1, FPos.Y + 1); SelText := Pad(res - 1); end; procedure TfrxSyntaxMemo.UnIndent; var i, res: Integer; begin i := FPos.Y - 2; res := FPos.X - 1; CorrectBookmark(FPos.Y, -1); while i >= 0 do begin res := GetLineBegin(i); if (res < FPos.X) and (Trim(FText[i]) <> '') then break else Dec(i); end; FSelStart := FPos; FSelEnd := FPos; Dec(FSelEnd.X, FPos.X - res); SelText := ''; end; procedure TfrxSyntaxMemo.ShiftSelected(ShiftRight: Boolean); var i, ib, ie: Integer; s: String; Shift: Integer; begin AddUndo; if FSelStart.X + FSelStart.Y * FMaxLength < FSelEnd.X + FSelEnd.Y * FMaxLength then begin ib := FSelStart.Y - 1; ie := FSelEnd.Y - 1; end else begin ib := FSelEnd.Y - 1; ie := FSelStart.Y - 1; end; if FSelEnd.X = 1 then Dec(ie); Shift := 2; if not ShiftRight then for i := ib to ie do begin s := FText[i]; if (Trim(s) <> '') and (GetLineBegin(i) - 1 < Shift) then Shift := GetLineBegin(i) - 1; end; for i := ib to ie do begin s := FText[i]; if ShiftRight then s := Pad(Shift) + s else if Trim(s) <> '' then Delete(s, 1, Shift); FText[i] := s; end; ClearSyntax(FSelStart.Y); DoChange; end; function TfrxSyntaxMemo.GetSelText: String; var p1, p2: TPoint; i: Integer; begin if FSelStart.X = 0 then begin Result := ''; Exit; end; if FSelStart.X + FSelStart.Y * FMaxLength < FSelEnd.X + FSelEnd.Y * FMaxLength then begin p1 := FSelStart; p2 := FSelEnd; Dec(p2.X); end else begin p1 := FSelEnd; p2 := FSelStart; Dec(p2.X); end; if LineLength(p1.Y - 1) < p1.X then begin Inc(p1.Y); p1.X := 1; end; if LineLength(p2.Y - 1) < p2.X then p2.X := LineLength(p2.Y - 1); i := GetPlainTextPos(p1); Result := Copy(FText.Text, i, GetPlainTextPos(p2) - i + 1); end; procedure TfrxSyntaxMemo.SetSelText(const Value: String); var p1, p2, p3: TPoint; i: Integer; s: String; begin AddUndo; if FSelStart.X = 0 then begin p1 := FPos; p2 := p1; Dec(p2.X); end else if FSelStart.X + FSelStart.Y * FMaxLength < FSelEnd.X + FSelEnd.Y * FMaxLength then begin p1 := FSelStart; p2 := FSelEnd; Dec(p2.X); end else begin p1 := FSelEnd; p2 := FSelStart; Dec(p2.X); end; FAllowLinesChange := False; if LineLength(p1.Y - 1) < p1.X then FText[p1.Y - 1] := FText[p1.Y - 1] + Pad(p1.X - LineLength(p1.Y - 1) + 1); if LineLength(p2.Y - 1) < p2.X then p2.X := LineLength(p2.Y - 1); i := GetPlainTextPos(p1); s := FText.Text; Delete(s, i, GetPlainTextPos(p2) - i + 1); Insert(Value, s, i); FText.Text := s; p3 := GetPosPlainText(i + Length(Value)); FAllowLinesChange := True; CorrectBookmark(FPos.Y, p3.y - FPos.Y); SetPos(p3.X, p3.Y); FSelStart.X := 0; DoChange; i := p3.Y; if p2.Y < i then i := p2.Y; if p1.Y < i then i := p1.Y; ClearSyntax(i); end; procedure TfrxSyntaxMemo.ClearSel; begin if FSelStart.X <> 0 then begin FSelStart := Point(0, 0); Repaint; end; end; procedure TfrxSyntaxMemo.AddSel; begin if FSelStart.X = 0 then FSelStart := FTempPos; FSelEnd := FPos; Repaint; end; procedure TfrxSyntaxMemo.SetPos(x, y: Integer); begin if FMessage <> '' then begin FMessage := ''; Repaint; end; if x > FMaxLength then x := FMaxLength; if x < 1 then x := 1; if y > FText.Count then y := FText.Count; if y < 1 then y := 1; FPos := Point(x, y); if (FWindowSize.X = 0) or (FWindowSize.Y = 0) then exit; if FOffset.Y >= FText.Count then FOffset.Y := FText.Count - 1; if FPos.X > FOffset.X + FWindowSize.X then begin Inc(FOffset.X, FPos.X - (FOffset.X + FWindowSize.X)); Repaint; end else if FPos.X <= FOffset.X then begin Dec(FOffset.X, FOffset.X - FPos.X + 1); Repaint; end else if FPos.Y > FOffset.Y + FWindowSize.Y then begin Inc(FOffset.Y, FPos.Y - (FOffset.Y + FWindowSize.Y)); Repaint; end else if FPos.Y <= FOffset.Y then begin Dec(FOffset.Y, FOffset.Y - FPos.Y + 1); Repaint; end; ShowCaretPos; UpdateScrollBar; end; procedure TfrxSyntaxMemo.OnHScrollChange(Sender: TObject); begin FOffset.X := HorzPosition; if FOffset.X > 1024 then FOffset.X := 1024; ShowCaretPos; Repaint; end; procedure TfrxSyntaxMemo.OnVScrollChange(Sender: TObject); begin FOffset.Y := VertPosition; if FOffset.Y > FText.Count then FOffset.Y := FText.Count; ShowCaretPos; Repaint; end; procedure TfrxSyntaxMemo.DblClick; var s: String; begin FDoubleClicked := True; DoCtrlL; FSelStart := FPos; s := LineAt(FPos.Y - 1); if s <> '' then while CharInSet(s[FPos.X], WordChars) or IsUnicodeChar(s[FPos.X]) do Inc(FPos.X); FSelEnd := FPos; Repaint; end; procedure TfrxSyntaxMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if FDoubleClicked then begin FDoubleClicked := False; Exit; end; FMoved := True; if not Focused then SetFocus; FDown := True; if X < FGutterWidth then FToggleBreakPointDown := True; X := (X - FGutterWidth) div FCharWidth + 1 + FOffset.X; Y := Y div FCharHeight + 1 + FOffset.Y; FTempPos := FPos; SetPos(X, Y); if ssShift in Shift then AddSel else ClearSel; end; procedure TfrxSyntaxMemo.MouseMove(Shift: TShiftState; X, Y: Integer); begin if FDown then begin FTempPos := FPos; FPos.X := (X - FGutterWidth) div FCharWidth + 1 + FOffset.X; FPos.Y := Y div FCharHeight + 1 + FOffset.Y; if (FPos.X <> FTempPos.X) or (FPos.Y <> FTempPos.Y) then begin SetPos(FPos.X, FPos.Y); AddSel; end; end; if X < FGutterWidth then Cursor := crArrow else Cursor := crIBeam; end; procedure TfrxSyntaxMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FDown := False; if (X < FGutterWidth) and (FToggleBreakPointDown) then ToggleBreakPoint(FPos.Y, ''); FToggleBreakPointDown := False; end; procedure TfrxSyntaxMemo.KeyDown(var Key: Word; Shift: TShiftState); var MyKey: Boolean; TempPos: Tpoint; begin inherited; FAllowLinesChange := False; FTempPos := FPos; MyKey := True; case Key of vk_Left: if ssCtrl in Shift then DoCtrlL else DoLeft; vk_Right: if ssCtrl in Shift then DoCtrlR else DoRight; vk_Up: DoUp; vk_Down: DoDown; vk_Home: DoHome(ssCtrl in Shift); vk_End: DoEnd(ssCtrl in Shift); vk_Prior: DoPgUp; vk_Next: DoPgDn; vk_Return: if Shift = [] then DoReturn; vk_Delete: begin if ssCtrl in Shift then // Ctrl+Del delete word before cursor begin TempPos := FPos; Inc(FPos.X); DblClick; FDoubleClicked := False; if FSelEnd.X <= TempPos.X then begin FSelStart := TempPos; FSelEnd := TempPos; dec(FSelStart.X); end; end; if ssShift in Shift then CutToClipboard else DoDel; end; vk_Back: begin if ssCtrl in Shift then // Ctrl+BackSpace delete word after cursor begin DblClick; FDoubleClicked := False; end; DoBackspace; end; vk_Insert: if ssCtrl in Shift then CopyToClipboard else if ssShift in Shift then PasteFromClipboard; vk_Tab: TabIndent; else MyKey := False; end; if Shift = [ssCtrl] then if Key = 65 then // Ctrl+A Select all begin SelectAll; end else if Key = 89 then // Ctrl+Y Delete line begin if FText.Count > FPos.Y then begin FMoved := True; AddUndo; FText.Delete(FPos.Y - 1); CorrectBookmark(FPos.Y, -1); DoChange; end else if FText.Count = FPos.Y then begin FMoved := True; AddUndo; FText[FPos.Y - 1] := ''; FPos.X := 1; SetPos(FPos.X, FPos.Y); DoChange; end; ClearSyntax(FPos.Y); end else if Key in [48..57] then GotoBookmark(Key - 48) else if Key = 32 then // Ctrl+Space code completion begin if Assigned(FOnCodeCompletion) then DoCodeCompletion; MyKey := True; end else if Key = Ord('C') then begin CopyToClipboard; MyKey := True; end else if Key = Ord('V') then begin PasteFromClipboard; MyKey := True; end else if Key = Ord('X') then begin CutToClipboard; MyKey := True; end else if Key = Ord('I') then begin DoCtrlI; MyKey := True; end else if Key = Ord('U') then begin DoCtrlU; MyKey := True; end else if Key = Ord('Z') then begin Undo; MyKey := True; end; if Shift = [ssCtrl, ssShift] then if Key in [48..57] then if IsBookmark(FPos.Y - 1) < 0 then AddBookmark(FPos.Y - 1, Key - 48) else if IsBookmark(FPos.Y - 1) = (Key - 48) then DeleteBookmark(Key - 48); if Key in [vk_Left, vk_Right, vk_Up, vk_Down, vk_Home, vk_End, vk_Prior, vk_Next] then begin FMoved := True; if ssShift in Shift then AddSel else ClearSel; end else if Key in [vk_Return, vk_Delete, vk_Back, vk_Insert, vk_Tab] then FMoved := True; if MyKey then Key := 0; end; procedure TfrxSyntaxMemo.KeyPress(var Key: Char); var MyKey, ControlKeyDown: Boolean; begin inherited; ControlKeyDown := (((GetKeyState(VK_LCONTROL) and not $7FFF) <> 0) or ((GetKeyState(VK_RCONTROL) and not $7FFF) <> 0)) and (GetKeyState(VK_RMENU) >= 0); MyKey := True; if ((Key = #32) and not ControlKeyDown) or (CharInSet(Key, [#33..#255])) or IsUnicodeChar(Key) and not((Key = #127) and ControlKeyDown) then begin DoChar(Key); FMoved := False; end else MyKey := False; if MyKey then Key := #0; end; procedure TfrxSyntaxMemo.DoCodeCompletion; var p: TPoint; function GetCompletionString: String; var i: Integer; s: String; fl1, fl2: Boolean; fl3, fl4: Integer; begin Result := ''; s := LineAt(FPos.Y - 1); s := Trim(Copy(s, 1, FPos.X)); fl1 := False; fl2 := False; fl3 := 0; fl4 := 0; i := Length(s); while i > 1 do begin Dec(i); if (s[i] = '''') and not fl2 then fl1 := not fl1 else if (s[i] = '"') and not fl1 then fl2 := not fl2 else if not fl1 and not fl2 and (s[i] = ')') then Inc(fl3) else if not fl1 and not fl2 and (s[i] = '(') and (fl3 > 0) then Dec(fl3) else if not fl1 and not fl2 and (s[i] = ']') then Inc(fl4) else if not fl1 and not fl2 and (s[i] = '[') and (fl4 > 0) then Dec(fl4) else if not fl1 and not fl2 and (fl3 = 0) and (fl4 = 0) then if CharInSet(s[i], ['A'..'Z', 'a'..'z', '0'..'9', '_', '.', ' ']) or IsUnicodeChar(s[i]) then Result := s[i] + Result else break; end; end; begin FCompletionForm := TfrxPopupForm.Create(Self); FCompletionLB := TListBox.Create(FCompletionForm); with FCompletionLB do begin Parent := FCompletionForm; Ctl3D := False; Align := alClient; ItemHeight := ItemHeight + 2; Style := lbOwnerDrawFixed; Sorted := True; OnDblClick := CompletionLBDblClick; OnKeyDown := CompletionLBKeyDown; OnDrawItem := CompletionLBDrawItem; if Assigned(FOnCodeCompletion) then FOnCodeCompletion(GetCompletionString, Items); p := Self.ClientToScreen( Point(FCharWidth * (FPos.X - 1 - FOffset.X) + FGutterWidth, FCharHeight * (FPos.Y - FOffset.Y))); FCompletionForm.SetBounds(p.X, p.Y, 300, 100); FCompletionForm.Show; end; end; procedure TfrxSyntaxMemo.CompletionLBDblClick(Sender: TObject); var s, s1: String; i: Integer; stepBack: Boolean; begin if FCompletionLB.ItemIndex <> -1 then begin s := FCompletionLB.Items[FCompletionLB.ItemIndex]; i := 2; while (i <= Length(s)) and ((CharInSet(s[i], WordChars) or IsUnicodeChar(s[i]))) do Inc(i); s1 := Copy(s, 1, i - 1); stepBack := (i <= Length(s)) and (s[i] = '('); if stepBack then s1 := s1 + '()'; SelText := s1; if stepBack then DoLeft; end; FCompletionForm.Close; end; procedure TfrxSyntaxMemo.CompletionLBKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Key = VK_ESCAPE then FCompletionForm.Close; if Key = VK_RETURN then CompletionLBDblClick(nil); end; procedure TfrxSyntaxMemo.CompletionLBDrawItem(Control: TWinControl; Index: Integer; ARect: TRect; State: TOwnerDrawState); var i, w: Integer; s: String; begin with FCompletionLB.Canvas do begin FillRect(ARect); if Index <> -1 then begin i := Integer(FCompletionLB.Items.Objects[Index]); s := ''; Font.Color := clFuchsia; if Pos('Constructor', FCompletionLB.Items[Index]) <> 0 then s := 'constructor' else case i of 0: begin s := 'var'; Font.Color := clBlue; end; 1: begin s := 'property'; Font.Color := clBlue; end; 2: s := 'procedure'; 3: s := 'function'; end; if odSelected in State then Font.Color := clWhite; Font.Style := []; TextOut(ARect.Left + 2, ARect.Top + 2, s); w := TextWidth('constructor'); Font.Color := clBlack; if odSelected in State then Font.Color := clWhite; Font.Style := [fsBold]; s := FCompletionLB.Items[Index]; i := 1; while (i <= Length(s)) and ((CharInSet(s[i], WordChars)) or IsUnicodeChar(s[i])) do Inc(i); s := Copy(s, 1, i - 1); TextOut(ARect.Left + w + 6, ARect.Top + 2, s); w := w + TextWidth(s); Font.Style := []; s := Copy(FCompletionLB.Items[Index], i, 255); if Pos(': Constructor', s) <> 0 then s := Copy(s, 1, Pos(': Constructor', s) - 1); TextOut(ARect.Left + w + 6, ARect.Top + 2, s); end; end; end; procedure TfrxSyntaxMemo.DoLeft; begin Dec(FPos.X); if FPos.X < 1 then FPos.X := 1; SetPos(FPos.X, FPos.Y); end; procedure TfrxSyntaxMemo.DoRight; begin Inc(FPos.X); if FPos.X > FMaxLength then FPos.X := FMaxLength; SetPos(FPos.X, FPos.Y); end; procedure TfrxSyntaxMemo.DoUp; begin Dec(FPos.Y); if FPos.Y < 1 then FPos.Y := 1; SetPos(FPos.X, FPos.Y); end; procedure TfrxSyntaxMemo.DoDown; begin Inc(FPos.Y); if FPos.Y > FText.Count then FPos.Y := FText.Count; SetPos(FPos.X, FPos.Y); end; procedure TfrxSyntaxMemo.DoHome(Ctrl: Boolean); begin if Ctrl then SetPos(1, 1) else SetPos(1, FPos.Y); end; procedure TfrxSyntaxMemo.DoEnd(Ctrl: Boolean); begin if Ctrl then SetPos(LineLength(FText.Count - 1) + 1, FText.Count) else SetPos(LineLength(FPos.Y - 1) + 1, FPos.Y); end; procedure TfrxSyntaxMemo.DoPgUp; begin if FOffset.Y > FWindowSize.Y then begin Dec(FOffset.Y, FWindowSize.Y - 1); Dec(FPos.Y, FWindowSize.Y - 1); end else begin if FOffset.Y > 0 then begin Dec(FPos.Y, FOffset.Y); FOffset.Y := 0; end else FPos.Y := 1; end; SetPos(FPos.X, FPos.Y); Repaint; end; procedure TfrxSyntaxMemo.DoPgDn; begin if FOffset.Y + FWindowSize.Y < FText.Count then begin Inc(FOffset.Y, FWindowSize.Y - 1); Inc(FPos.Y, FWindowSize.Y - 1); end else begin FOffset.Y := FText.Count; FPos.Y := FText.Count; end; SetPos(FPos.X, FPos.Y); Repaint; end; procedure TfrxSyntaxMemo.DoReturn; var s: String; begin s := LineAt(FPos.Y - 1); FText[FPos.Y - 1] := Copy(s, 1, FPos.X - 1); FText.Insert(FPos.Y, Copy(s, FPos.X, FMaxLength)); EnterIndent; end; procedure TfrxSyntaxMemo.DoDel; var s: String; begin FMessage := ''; if FSelStart.X <> 0 then SelText := '' else begin s := FText[FPos.Y - 1]; AddUndo; if FPos.X <= LineLength(FPos.Y - 1) then begin Delete(s, FPos.X, 1); FText[FPos.Y - 1] := s; end else if FPos.Y < FText.Count then begin s := s + Pad(FPos.X - Length(s) - 1) + LineAt(FPos.Y); FText[FPos.Y - 1] := s; FText.Delete(FPos.Y); CorrectBookmark(FPos.Y, -1); end; UpdateScrollBar; ClearSyntax(FPos.Y); DoChange; end; end; procedure TfrxSyntaxMemo.DoBackspace; var s: String; begin FMessage := ''; if FSelStart.X <> 0 then SelText := '' else begin s := FText[FPos.Y - 1]; if FPos.X > 1 then begin if (GetLineBegin(FPos.Y - 1) = FPos.X) or (Trim(s) = '') then UnIndent else begin AddUndo; if Trim(s) <> '' then begin Delete(s, FPos.X - 1, 1); FText[FPos.Y - 1] := s; DoLeft; end else DoHome(False); ClearSyntax(FPos.Y); DoChange; end; end else if FPos.Y > 1 then begin AddUndo; CorrectBookmark(FPos.Y, -1); s := LineAt(FPos.Y - 2); FText[FPos.Y - 2] := s + FText[FPos.Y - 1]; FText.Delete(FPos.Y - 1); SetPos(Length(s) + 1, FPos.Y - 1); ClearSyntax(FPos.Y); DoChange; end; end; end; procedure TfrxSyntaxMemo.DoCtrlI; begin if FSelStart.X <> 0 then ShiftSelected(True); end; procedure TfrxSyntaxMemo.DoCtrlU; begin if FSelStart.X <> 0 then ShiftSelected(False); end; procedure TfrxSyntaxMemo.DoCtrlL; var i: Integer; s: String; begin s := FText.Text; i := Length(LineAt(FPos.Y - 1)); if FPos.X > i then FPos.X := i; i := GetPlainTextPos(FPos); Dec(i); while (i > 0) and not ((CharInSet(s[i], WordChars)) or IsUnicodeChar(s[i])) do if s[i] = #13 then break else Dec(i); while (i > 0) and ((CharInSet(s[i], WordChars)) or IsUnicodeChar(s[i])) do Dec(i); Inc(i); FPos := GetPosPlainText(i); SetPos(FPos.X, FPos.Y); end; procedure TfrxSyntaxMemo.DoCtrlR; var i: Integer; s: String; begin s := FText.Text; i := Length(LineAt(FPos.Y - 1)); if FPos.X > i then begin DoDown; DoHome(False); FPos.X := 0; end; i := GetPlainTextPos(FPos); while (i < Length(s)) and ((CharInSet(s[i], WordChars)) or IsUnicodeChar(s[i])) do Inc(i); while (i < Length(s)) and not ((CharInSet(s[i], WordChars)) or IsUnicodeChar(s[i])) do if s[i] = #13 then begin while (i > 1) and (s[i - 1] = ' ') do Dec(i); break; end else Inc(i); FPos := GetPosPlainText(i); SetPos(FPos.X, FPos.Y); end; procedure TfrxSyntaxMemo.DoChar(Ch: Char); begin SelText := Ch; end; function TfrxSyntaxMemo.GetCharAttr(Pos: TPoint): TCharAttributes; function IsBlock: Boolean; var p1, p2, p3: Integer; begin Result := False; if FSelStart.X = 0 then Exit; p1 := FSelStart.X + FSelStart.Y * FMaxLength; p2 := FSelEnd.X + FSelEnd.Y * FMaxLength; if p1 > p2 then begin p3 := p1; p1 := p2; p2 := p3; end; p3 := Pos.X + Pos.Y * FMaxLength; Result := (p3 >= p1) and (p3 < p2); end; function CharAttr: TCharAttr; var s: String; begin if Pos.Y - 1 < FSynStrings.Count then begin s := FSynStrings[Pos.Y - 1]; if Pos.X <= Length(s) then Result := TCharAttr(Ord(s[Pos.X])) else Result := caText; end else Result := caText; end; begin Result := [CharAttr]; if IsBlock then Result := Result + [caBlock]; end; function TfrxSyntaxMemo.GetCharWidth(Str: String): Integer; begin with FTmpCanvas.Canvas do begin Font.Assign(Self.Font); Result := TextWidth(Str); end; end; procedure TfrxSyntaxMemo.Paint; var i, j, j1: Integer; a, a1: TCharAttributes; s: String; procedure SetAttr(a: TCharAttributes; Line: Integer); begin with Canvas do begin Brush.Color := Color; if caText in a then Font.Assign(FTextAttr); if caComment in a then Font.Assign(FCommentAttr); if caKeyword in a then Font.Assign(FKeywordAttr); if caNumber in a then Font.Assign(FNumberAttr); if caString in a then Font.Assign(FStringAttr); if (caBlock in a) or (Line = FActiveLine - 1) then begin Brush.Color := FBlockColor; Font.Color := FBlockFontColor; end; Font.Charset := Self.Font.Charset; end; end; procedure MyTextOut(x, y: Integer; const s: String); var i: Integer; begin if FIsMonoType then begin Canvas.FillRect(Rect(x, y, x + Length(s) * FCharWidth, y + FCharHeight)); Canvas.TextOut(x, y, s) end else with Canvas do begin FillRect(Rect(x, y, x + Length(s) * FCharWidth, y + FCharHeight)); for i := 1 to Length(s) do TextOut(x + (i - 1) * FCharWidth, y, s[i]); MoveTo(x + Length(s) * FCharWidth, y); end; end; procedure DrawLineMarks(Line, Y: Integer); begin if not FShowGutter then Exit; if IsBookmark(Line) >= 0 then with Canvas do begin Brush.Color := clBlack; FillRect(Rect(13, Y + 3, 23, Y + 14)); Brush.Color := clGreen; FillRect(Rect(12, Y + 4, 22, Y + 15)); Font.Name := 'Tahoma'; Font.Color := clWhite; Font.Style := [fsBold]; Font.Size := 7; TextOut(14, Y + 4, IntToStr(IsBookmark(Line))); end; if RunLine[Line + 1] then with Canvas do begin Brush.Color := clBlue; Pen.Color := clBlack; Ellipse(4, Y + 7, 8, Y + 11); Pixels[5, Y + 7] := clAqua; Pixels[4, Y + 8] := clAqua; end; if IsBreakPoint(Line + 1) then with Canvas do begin Brush.Color := clRed; Pen.Color := clRed; Ellipse(2, Y + 4, 13, Y + 15); end; end; begin inherited; with Canvas do begin Brush.Color := clBtnFace; FillRect(Rect(0, 0, FGutterWidth - 2, Height)); Pen.Color := clBtnHighlight; MoveTo(FGutterWidth - 4, 0); LineTo(FGutterWidth - 4, Height + 1); if FUpdatingSyntax then Exit; CreateSynArray(FOffset.Y + FWindowSize.Y - 1); for i := FOffset.Y to FOffset.Y + FWindowSize.Y - 1 do begin if i >= FText.Count then break; s := FText[i]; PenPos := Point(FGutterWidth, (i - FOffset.Y) * FCharHeight); j1 := FOffset.X + 1; a := GetCharAttr(Point(j1, i + 1)); a1 := a; for j := j1 to FOffset.X + FWindowSize.X do begin if j > Length(s) then break; a1 := GetCharAttr(Point(j, i + 1)); if a1 <> a then begin SetAttr(a, i); MyTextOut(PenPos.X, PenPos.Y, Copy(FText[i], j1, j - j1)); a := a1; j1 := j; end; end; SetAttr(a, i); MyTextOut(PenPos.X, PenPos.Y, Copy(s, j1, FMaxLength)); if (caBlock in GetCharAttr(Point(1, i + 1))) or (i = FActiveLine - 1) then MyTextOut(PenPos.X, PenPos.Y, Pad(FWindowSize.X - Length(s) - FOffset.X + 3)); DrawLineMarks(i, PenPos.Y); end; if FMessage <> '' then begin Font.Name := 'Tahoma'; Font.Color := clWhite; Font.Style := [fsBold]; Font.Size := 8; Brush.Color := clMaroon; FillRect(Rect(0, ClientHeight - TextHeight('|') - 6, ClientWidth, ClientHeight)); TextOut(6, ClientHeight - TextHeight('|') - 5, FMessage); end end; end; procedure TfrxSyntaxMemo.ClearSyntax(ClearFrom: Integer); begin Dec(ClearFrom); if ClearFrom < 1 then ClearFrom := 1; FUpdatingSyntax := True; while FSynStrings.Count > ClearFrom - 1 do FSynStrings.Delete(FSynStrings.Count - 1); FUpdatingSyntax := False; Repaint; end; procedure TfrxSyntaxMemo.CreateSynArray(EndLine: Integer); var i, j, n, Max: Integer; FSyn, s: String; attr: TCharAttr; begin if EndLine >= FText.Count then EndLine := FText.Count - 1; if EndLine <= FSynStrings.Count - 1 then Exit; FUpdatingSyntax := True; FAllowLinesChange := False; for i := FSynStrings.Count to EndLine do FSynStrings.Add(FText[i]); FSyn := FSynStrings.Text; FParser.Text := FText.Text; Max := Length(FSyn); for i := Length(FSyn) downto 1 do if FSyn[i] = Chr(Ord(caText)) then begin j := i; while (j > 1) and (FSyn[j] = Chr(Ord(caText))) do Dec(j); FParser.Position := j + 1; break; end; while FParser.Position < Max do begin n := FParser.Position; FParser.SkipSpaces; for i := n to FParser.Position - 1 do if i <= Max then if FSyn[i] > #31 then FSyn[i] := Chr(Ord(caComment)); attr := caText; n := FParser.Position; s := FParser.GetWord; if s <> '' then begin if FParser.IsKeyword(s) then attr := caKeyword; end else begin s := FParser.GetNumber; if s <> '' then attr := caNumber else begin s := FParser.GetString; if s <> '' then attr := caString else FParser.Position := FParser.Position + 1 end end; for i := n to FParser.Position - 1 do if i <= Max then if FSyn[i] > #31 then FSyn[i] := Chr(Ord(attr)); end; FSynStrings.Text := FSyn; FUpdatingSyntax := False; FAllowLinesChange := True; end; procedure TfrxSyntaxMemo.UpdateView; begin Invalidate; end; procedure TfrxSyntaxMemo.MouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); begin VertPosition := VertPosition - SmallChange; end; procedure TfrxSyntaxMemo.MouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); begin VertPosition := VertPosition + SmallChange; end; procedure TfrxSyntaxMemo.SetShowGutter(Value: Boolean); begin FShowGutter := Value; if Value then FGutterWidth := 30 else FGutterWidth := 0; Repaint; end; function TfrxSyntaxMemo.IsBookmark(Line: Integer): Integer; var i: Integer; begin Result := -1; for i := 0 to 9 do if FBookmarks[i] = Line then begin Result := i; break; end; end; procedure TfrxSyntaxMemo.AddBookmark(Line, Number: Integer); begin if Number < Length(FBookmarks) then begin FBookmarks[Number] := Line; Repaint; end; end; procedure TfrxSyntaxMemo.DeleteBookmark(Number: Integer); begin if Number < Length(FBookmarks) then begin FBookmarks[Number] := -1; Repaint; end; end; procedure TfrxSyntaxMemo.CorrectBookmark(Line, Delta: Integer); var i: Integer; begin if Delta = 0 then exit; CorrectBreakPoints(Line, Delta); for i := 0 to Length(FBookmarks) - 1 do if FBookmarks[i] >= Line then Inc(FBookmarks[i], Delta); end; procedure TfrxSyntaxMemo.GotoBookmark(Number : Integer); begin if Number < Length(FBookmarks) then if FBookmarks[Number] >= 0 then SetPos(0, FBookmarks[Number] + 1); end; function TfrxSyntaxMemo.GetRunLine(Index: Integer): Boolean; begin if (Index < 1) or (Index > FText.Count) then Result := False else Result := FText.Objects[Index - 1] = Pointer(1); end; procedure TfrxSyntaxMemo.SetRunLine(Index: Integer; const Value: Boolean); begin if (Index < 1) or (Index > FText.Count) then Exit; if Value then FText.Objects[Index - 1] := Pointer(1) else FText.Objects[Index - 1] := Pointer(0); end; function TfrxSyntaxMemo.Find(const SearchText: String; CaseSensitive: Boolean; var SearchFrom: Integer): Boolean; var i: Integer; s: String; begin i := 0; Result := False; if FText.Count > 1 then begin s := FText.Text; if SearchFrom = 0 then SearchFrom := 1; s := Copy(s, SearchFrom, Length(s) - SearchFrom + 1); if CaseSensitive then begin i := Pos(SearchText, s); if i <> 0 then Result := True; end else begin i := Pos(AnsiUpperCase(SearchText), AnsiUpperCase(s)); if i <> 0 then Result := True; end; end; if Result then begin Inc(SearchFrom, i); FSelStart := GetPosPlainText(SearchFrom - 1); FSelEnd := Point(FSelStart.X + Length(SearchText), FSelStart.Y); Inc(SearchFrom, Length(SearchText)); SetPos(FSelStart.X, FSelStart.Y); Repaint; end; end; procedure TfrxSyntaxMemo.AddBreakPoint(Number: Integer; const Condition: String); begin FBreakPoints.AddObject(Condition, TObject(Number)); Repaint; end; procedure TfrxSyntaxMemo.ToggleBreakPoint(Number: Integer; const Condition: String); begin if IsBreakPoint(Number) then DeleteBreakPoint(Number) else AddBreakPoint(Number, Condition); end; procedure TfrxSyntaxMemo.DeleteBreakPoint(Number: Integer); begin if IsBreakPoint(Number) then FBreakPoints.Delete(FBreakPoints.IndexOfObject(TObject(Number))); Repaint; end; function TfrxSyntaxMemo.IsBreakPoint(Number: Integer): Boolean; begin Result := FBreakPoints.IndexOfObject(TObject(Number)) <> -1; end; function TfrxSyntaxMemo.GetBreakPointCondition(Number: Integer): String; begin Result := ''; if IsBreakPoint(Number) then Result := FBreakPoints[FBreakPoints.IndexOfObject(TObject(Number))]; end; procedure TfrxSyntaxMemo.DeleteF4BreakPoints; var i: Integer; begin i := 0; while i < FBreakPoints.Count do if FBreakPoints[i] = 'F4' then FBreakPoints.Delete(i) else Inc(i); end; procedure TfrxSyntaxMemo.CorrectBreakPoints(Line, Delta: Integer); var i, bPos: Integer; begin // FBreakPoints[FBreakPoints.IndexOfObject(TObject(Number))] for i := 0 to FBreakPoints.Count - 1 do begin bPos := Integer(FBreakPoints.Objects[i]); if bPos >= Line then begin Inc(bPos, Delta); FBreakPoints.Objects[i] := TObject(bPos); end; end; end; function TfrxSyntaxMemo.GetTextSelected: Boolean; begin // Result := True;// FSelStart end; end.