// // The multimedia graphics platform GLScene https://github.com/glscene // unit GLS.Memo; (* Memo for GLScene *) interface {$I GLScene.inc} uses WinApi.Windows, WinApi.Messages, System.SysUtils, System.Classes, System.UITypes, VCL.Graphics, VCL.Controls, VCL.Forms, VCL.Dialogs, VCL.ClipBrd, VCL.StdCtrls, VCL.ExtCtrls; type TBorderType = (btRaised, btLowered, btFlatRaised, btFlatLowered); TCommand = Integer; TCellSize = record W, H: integer; end; TCellPos = record X, Y: integer; end; TFullPos = record LineNo, Pos: integer; end; TLineProp = class FObject: TObject; FStyleNo: integer; FInComment: Boolean; FInBrackets: integer; FValidAttrs: Boolean; FCharAttrs: string; end; TCharStyle = class(TPersistent) private FTextColor, FBkColor: TColor; FStyle: TFontStyles; published property TextColor: TColor read FTextColor write FTextColor; property BkColor: TColor read FBkColor write FBkColor; property Style: TFontStyles read FStyle write FStyle; end; TStyleList = class(TList) private procedure CheckRange(Index: integer); function GetTextColor(Index: Integer): TColor; procedure SetTextColor(Index: Integer; Value: TColor); function GetBkColor(Index: Integer): TColor; procedure SetBkColor(Index: Integer; Value: TColor); function GetStyle(Index: Integer): TFontStyles; procedure SetStyle(Index: Integer; Value: TFontStyles); protected property TextColor[Index: Integer]: TColor read GetTextColor write SetTextColor; property BkColor[Index: Integer]: TColor read GetBkColor write SetBkColor; property Style[Index: Integer]: TFontStyles read GetStyle write SetStyle; public destructor Destroy; override; procedure Clear; override; procedure Delete(Index: Integer); function Add(ATextColor, ABkCOlor: TColor; AStyle: TFontStyles): Integer; procedure Change(Index: integer; ATextColor, ABkColor: TColor; AStyle: TFontStyles); end; TGLAbstractMemoObject = class(TObject) public function MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; virtual; abstract; function MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; virtual; abstract; function MouseMove(Shift: TShiftState; X, Y: Integer): Boolean; virtual; abstract; end; TGLSMemoScrollBar = class; TGLSMemoAbstractScrollableObject = class(TCustomControl) protected procedure DoScroll(Sender: TGLSMemoScrollBar; ByValue: integer); virtual; abstract; procedure DoScrollPage(Sender: TGLSMemoScrollBar; ByValue: integer); virtual; abstract; end; TGLSCustomMemo = class; TsbState = ( sbsWait, sbsBack, sbsForward, sbsPageBack, sbsPageForward, sbsDragging ); TGLSMemoScrollBar = class(TGLAbstractMemoObject) private FKind: TScrollBarKind; FParent: TGLSMemoAbstractScrollableObject; FLeft, FTop, FWidth, FHeight: integer; FTotal, FMaxPosition, FPosition: integer; FButtonLength: integer; FState: TsbState; FXOffset, FYOffset: integer; procedure SetParams(Index: integer; Value: integer); procedure SetState(Value: TsbState); function GetRect: TRect; function GetThumbRect: TRect; function GetBackRect: TRect; function GetMiddleRect: TRect; function GetForwardRect: TRect; function GetPgBackRect: TRect; function GetPgForwardRect: TRect; public constructor Create(AParent: TGLSMemoAbstractScrollableObject; AKind: TScrollBarKind); procedure PaintTo(ACanvas: TCanvas); function MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; override; function MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; override; function MouseMove(Shift: TShiftState; X, Y: Integer): Boolean; override; function MoveThumbTo(X, Y: Integer): integer; property Parent: TGLSMemoAbstractScrollableObject read FParent; property Kind: TScrollBarKind read FKind write FKind; property State: TsbState read FState write SetState; property Left: integer index 0 read FLeft write SetParams; property Top: integer index 1 read FTop write SetParams; property Width: integer index 2 read FWidth write SetParams; property Height: integer index 3 read FHeight write SetParams; property Total: integer index 4 read FTotal write SetParams; property MaxPosition: integer index 5 read FMaxPosition write SetParams; property Position: integer index 6 read FPosition write SetParams; property FullRect: TRect read GetRect; property ThumbRect: TRect read GetThumbRect; property BackRect: TRect read GetBackRect; property MiddleRect: TRect read GetMiddleRect; property ForwardRect: TRect read GetForwardRect; property PageForwardRect: TRect read GetPgForwardRect; property PageBackRect: TRect read GetPgBackRect; end; TGLSMemoStrings = class(TStringList) private FMemo: TGLSCustomMemo; FLockCount: integer; FDeleting: Boolean; procedure CheckRange(Index: integer); function GetLineProp(Index: integer): TLineProp; procedure SetLineStyle(Index: integer; Value: integer); function GetLineStyle(Index: integer): integer; function GetInComment(Index: Integer): Boolean; procedure SetInComment(Index: Integer; Value: Boolean); function GetInBrackets(Index: Integer): integer; procedure SetInBrackets(Index: Integer; Value: integer); function GetValidAttrs(Index: Integer): Boolean; procedure SetValidAttrs(Index: Integer; Value: Boolean); function GetCharAttrs(Index: Integer): string; procedure SetCharAttrs(Index: Integer; const Value: string); protected function GetObject(Index: Integer): TObject; override; procedure PutObject(Index: Integer; AObject: TObject); override; procedure SetUpdateState(Updating: Boolean); override; function CreateProp(Index: integer): TLineProp; property LineProp[Index: integer]: TLineProp read GetLineProp; //PALOFF property Style[Index: integer]: integer read GetLineStyle write SetLineStyle; property InComment[Index: integer]: Boolean read GetInComment write SetInComment; property InBrackets[Index: integer]: integer read GetInBrackets write SetInBrackets; property ValidAttrs[Index: integer]: Boolean read GetValidAttrs write SetValidAttrs; property CharAttrs[Index: integer]: string read GetCharAttrs write SetCharAttrs; public destructor Destroy; override; procedure Clear; override; function DoAdd(const S: string): Integer; function Add(const S: string): Integer; override; function AddObject(const S: string; AObject: TObject): Integer; override; procedure Assign(Source: TPersistent); override; procedure Insert(Index: Integer; const S: string); override; procedure DoInsert(Index: Integer; const S: string); procedure InsertObject(Index: Integer; const S: string; AObject: TObject); override; procedure Delete(Index: Integer); override; procedure LoadFromFile(const FileName: string); override; end; TGLSMemoGutter = class(TObject) private FMemo: TGLSCustomMemo; FLeft, FTop, FWidth, FHeight: integer; FColor: TColor; procedure SetParams(Index: integer; Value: integer); function GetRect: TRect; protected procedure PaintTo(ACanvas: TCanvas); procedure Invalidate; public property Left: integer index 0 read FLeft write SetParams; property Top: integer index 1 read FTop write SetParams; property Width: integer index 2 read FWidth write SetParams; property Height: integer index 3 read FHeight write SetParams; property FullRect: TRect read GetRect; end; TGLSMemoUndo = class private FMemo: TGLSCustomMemo; FUndoCurX0, FUndoCurY0: integer; FUndoCurX, FUndoCurY: integer; FUndoText: string; public constructor Create(ACurX0, ACurY0, ACurX, ACurY: integer; const AText: string); function Append(NewUndo: TGLSMemoUndo): Boolean; virtual; procedure Undo; procedure Redo; procedure PerformUndo; virtual; abstract; procedure PerformRedo; virtual; abstract; property UndoCurX0: integer read FUndoCurX0 write FUndoCurX0; property UndoCurY0: integer read FUndoCurY0 write FUndoCurY0; property UndoCurX: integer read FUndoCurX write FUndoCurX; property UndoCurY: integer read FUndoCurY write FUndoCurY; end; TGLSMemoInsCharUndo = class(TGLSMemoUndo) public function Append(NewUndo: TGLSMemoUndo): Boolean; override; procedure PerformUndo; override; procedure PerformRedo; override; end; TGLSMemoDelCharUndo = class(TGLSMemoUndo) private FIsBackspace: Boolean; public function Append(NewUndo: TGLSMemoUndo): Boolean; override; procedure PerformUndo; override; procedure PerformRedo; override; property IsBackspace: Boolean read FIsBackspace write FIsBackspace; end; TGLSMEmoDelLineUndo = class(TGLSMemoUndo) private FIndex: integer; public constructor Create(AIndex, ACurX0, ACurY0, ACurX, ACurY: integer; const AText: string); procedure PerformUndo; override; procedure PerformRedo; override; end; TGLSMemoSelUndo = class(TGLSMemoUndo) private FUndoSelStartX, FUndoSelStartY, FUndoSelEndX, FUndoSelEndY: integer; public property UndoSelStartX: integer read FUndoSelStartX write FUndoSelStartX; property UndoSelStartY: integer read FUndoSelStartY write FUndoSelStartY; property UndoSelEndX: integer read FUndoSelEndX write FUndoSelEndX; property UndoSelEndY: integer read FUndoSelEndY write FUndoSelEndY; end; TGLSMemoDeleteBufUndo = class(TGLSMemoSelUndo) public procedure PerformUndo; override; procedure PerformRedo; override; end; TGLSMemoPasteUndo = class(TGLSMemoUndo) public procedure PerformUndo; override; procedure PerformRedo; override; end; TGLSMemoUndoList = class(TList) private FPos: integer; FMemo: TGLSCustomMemo; FIsPerforming: Boolean; FLimit: integer; protected function Get(Index: Integer): TGLSMemoUndo; procedure SetLimit(Value: integer); public constructor Create; destructor Destroy; override; function Add(Item: Pointer): Integer; procedure Clear; override; procedure Delete(Index: Integer); procedure Undo; procedure Redo; property Items[Index: Integer]: TGLSMemoUndo read Get; default; property IsPerforming: Boolean read FIsPerforming write FIsPerforming; property Memo: TGLSCustomMemo read FMemo write FMemo; property Pos: integer read FPos write FPos; property Limit: integer read FLimit write SetLimit; end; //-------------------------------------------------------------- TGutterClickEvent = procedure(Sender: TObject; LineNo: integer) of object; TGutterDrawEvent = procedure(Sender: TObject; ACanvas: TCanvas; LineNo: integer; rct: TRect) of object; TGetLineAttrsEvent = procedure(Sender: TObject; LineNo: integer; var Attrs: string) of object; TUndoChangeEvent = procedure(Sender: TObject; CanUndo, CanRedo: Boolean) of object; TScrollMode = (smAuto, smStrict); TGLSCustomMemo = class(TGLSMemoAbstractScrollableObject) private FAutoIndent: Boolean; FMargin: integer; FHiddenCaret, FCaretVisible: Boolean; FCellSize: TCellSize; FCurX, FCurY: integer; FLeftCol, FTopLine: integer; FTabSize: integer; FFont: TFont; FBkColor: TColor; FSelColor: TColor; FSelBkColor: TColor; FReadOnly: Boolean; FDelErase: Boolean; FLines: TStrings; FSelStartX, FSelStartY, FSelEndX, FSelEndY, FPrevSelX, FPrevSelY: integer; FScrollBars: System.UITypes.TScrollStyle; FScrollBarWidth: integer; FGutter: TGLSMemoGutter; FGutterWidth: integer; sbVert, sbHorz: TGLSMemoScrollBar; FStyles: TStyleList; FLineBitmap: TBitmap; FSelCharPos: TFullPos; FSelCharStyle: integer; FLeftButtonDown: Boolean; FScrollMode: TScrollMode; FUndoList: TGLSMemoUndoList; FFirstUndoList: TGLSMemoUndoList; FUndoLimit: integer; FLastMouseUpX, FLastMouseUpY: integer; FAfterDoubleClick: Boolean; // events FOnMoveCursor: TNotifyEvent; FOnChange: TNotifyEvent; FOnAttrChange: TNotifyEvent; FOnStatusChange: TNotifyEvent; FOnSelectionChange: TNotifyEvent; FOnGutterDraw: TGutterDrawEvent; FOnGutterClick: TGutterClickEvent; FOnGetLineAttrs: TGetLineAttrsEvent; FOnUndoChange: TUndoChangeEvent; FHideCursor: Boolean; procedure SetHiddenCaret(Value: Boolean); procedure SetScrollBars(Value: System.UITypes.TScrollStyle); procedure SetGutterWidth(Value: integer); procedure SetGutterColor(Value: TColor); function GetGutterColor: TColor; procedure SetCurX(Value: integer); procedure SetCurY(Value: integer); procedure SetFont(Value: TFont); procedure SetColor(Index: integer; Value: TColor); function GetSelStart: TPoint; function GetSelEnd: TPoint; procedure SetLines(ALines: TStrings); procedure SetLineStyle(Index: integer; Value: integer); function GetLineStyle(Index: integer): integer; function GetInComment(Index: integer): Boolean; procedure SetInComment(Index: integer; Value: Boolean); function GetInBrackets(Index: Integer): integer; procedure SetInBrackets(Index: Integer; Value: integer); function GetValidAttrs(Index: integer): Boolean; procedure SetValidAttrs(Index: integer; Value: Boolean); function GetCharAttrs(Index: integer): string; procedure SetCharAttrs(Index: integer; const Value: string); procedure ExpandSelection; function GetSelText: string; procedure SetSelText(const AValue: string); function GetSelLength: integer; procedure MovePage(dP: integer; Shift: TShiftState); procedure ShowCaret(State: Boolean); procedure MakeVisible; function GetVisible(Index: integer): integer; function MaxLength: integer; procedure WMSize(var Msg: TWMSize); message WM_SIZE; procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE; procedure WMEraseBkgnd(var Msg: TWmEraseBkgnd); message WM_ERASEBKGND; procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR; procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; procedure WMKillFocus(var Msg: TWMSetFocus); message WM_KILLFOCUS; procedure WMMouseWheel(var Message: TMessage); message WM_MOUSEWHEEL; procedure MoveCursor(dX, dY: integer; Shift: TShiftState); procedure ResizeEditor; procedure ResizeScrollBars; procedure ResizeGutter; procedure DoCommand(cmd: TCommand; const AShift: TShiftState); procedure DrawLine(LineNo: integer); function IsLineVisible(LineNo: integer): Boolean; procedure FreshLineBitmap; procedure SetUndoLimit(Value: integer); protected procedure WndProc(var Message: TMessage); override; function EditorRect: TRect; function LineRangeRect(FromLine, ToLine: integer): TRect; function ColRangeRect(FromCol, ToCol: integer): TRect; procedure InvalidateLineRange(FromLine, ToLine: integer); function AddString(const S: string): integer; procedure InsertString(Index: integer; S: string); procedure GoHome(Shift: TShiftState); procedure GoEnd(Shift: TShiftState); procedure InsertChar(C: Char); procedure DeleteChar(OldX, OldY: integer); procedure DeleteLine(Index, OldX, OldY, NewX, NewY: integer; FixUndo: Boolean); procedure BackSpace; procedure BackSpaceWord; function IndentCurrLine: string; procedure NewLine; procedure CreateParams(var Params: TCreateParams); override; procedure Paint; override; procedure DrawMargin; procedure DrawGutter; procedure DrawScrollBars; 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 DblClick; override; procedure DoScroll(Sender: TGLSMemoScrollBar; ByValue: integer); override; procedure DoScrollPage(Sender: TGLSMemoScrollBar; ByValue: integer); override; property VisiblePosCount: integer index 0 read GetVisible; property VisibleLineCount: integer index 1 read GetVisible; property LastVisiblePos: integer index 2 read GetVisible; property LastVisibleLine: integer index 3 read GetVisible; procedure DeleteSelection(bRepaint: Boolean); procedure Changed(FromLine, ToLine: integer); virtual; procedure AttrChanged(LineNo: integer); virtual; procedure SelectionChanged; virtual; procedure StatusChanged; virtual; procedure ClearUndoList; procedure UndoChange; property AutoIndent: Boolean read FAutoIndent write FAutoIndent; property GutterWidth: integer read FGutterWidth write SetGutterWidth; property GutterColor: TColor read GetGutterColor write SetGutterColor; property ScrollBars: System.UITypes.TScrollStyle read FScrollBars write SetScrollBars default ssBoth; property Font: TFont read FFont write SetFont; property ReadOnly: Boolean read FReadOnly write FReadOnly; property Lines: TStrings read FLines write SetLines; property BkColor: TColor index 0 read FBkColor write SetColor; property SelColor: TColor index 1 read FSelColor write SetColor; property SelBkColor: TColor index 2 read FSelBkColor write SetColor; property HiddenCaret: Boolean read FHiddenCaret write SetHiddenCaret; property TabSize: integer read FTabSize write FTabSize; property ScrollMode: TScrollMode read FScrollMode write FScrollMode default smAuto; property UndoLimit: integer read FUndoLimit write SetUndoLimit; property HideCursor: Boolean read FHideCursor write FHideCursor; property InComment[Index: integer]: Boolean read GetInComment write SetInComment; property InBrackets[Index: integer]: integer read GetInBrackets write SetInBrackets; property ValidAttrs[Index: integer]: Boolean read GetValidAttrs write SetValidAttrs; property CharAttrs[Index: integer]: string read GetCharAttrs write SetCharAttrs; {events} property OnGutterClick: TGutterClickEvent read FOnGutterClick write FOnGutterClick; property OnGutterDraw: TGutterDrawEvent read FOnGutterDraw write FOnGutterDraw; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnMoveCursor: TNotifyEvent read FOnMoveCursor write FOnMoveCursor; property OnAttrChange: TNotifyEvent read FOnAttrChange write FOnAttrChange; property OnSelectionChange: TNotifyEvent read FOnSelectionChange write FOnSelectionChange; property OnStatusChange: TNotifyEvent read FOnStatusChange write FOnStatusChange; property OnGetLineAttrs: TGetLineAttrsEvent read FOnGetLineAttrs write FOnGetLineAttrs; property OnUndoChange: TUndoChangeEvent read FOnUndoChange write FOnUndoChange; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure CopyToClipBoard; procedure PasteFromClipBoard; procedure CutToClipBoard; procedure SelectLines(StartLine, EndLine: Integer); procedure SelectAll; property SelStart: TPoint read GetSelStart; property SelEnd: TPoint read GetSelEnd; property Selection: string read GetSelText write SetSelText; property SelLength: integer read GetSelLength; procedure ClearSelection; procedure Clear; procedure SetCursor(ACurX, ACurY: Integer); function SelectLine(LineNo, StyleNo: Integer): integer; procedure SelectChar(LineNo, Pos, StyleNo: Integer); function CellFromPos(X, Y: integer): TCellPos; function CharFromPos(X, Y: integer): TFullPos; function CellRect(ACol, ARow: integer): TRect; function LineRect(ARow: integer): TRect; function ColRect(ACol: integer): TRect; function CharStyleNo(LineNo, Pos: integer): integer; procedure InsertTemplate(AText: string); procedure UnSelectChar; procedure Undo; procedure Redo; function CanUndo: Boolean; function CanRedo: Boolean; function FindText(Text: string; Options: TFindOptions; Select: Boolean): Boolean; property CurX: integer read FCurX write SetCurX; property CurY: integer read FCurY write SetCurY; property DelErase: Boolean read FDelErase write FDelErase; property LineStyle[Index: integer]: integer read GetLineStyle write SetLineStyle; property Styles: TStyleList read FStyles; property UndoList: TGLSMemoUndoList read FUndoList write FUndoList; end; TGLSMemo = class(TGLSCustomMemo) published {TControl } property PopupMenu; {TCustomControl } property Align; property Enabled; property ShowHint; property TabOrder; property TabStop; property Visible; property ReadOnly; {TGLSCustomMemo } property AutoIndent; property GutterColor; property GutterWidth; property ScrollBars; property Font; property BkColor; property Selection; property SelColor; property SelBkColor; property Lines; property HiddenCaret; property TabSize; property ScrollMode; property UndoLimit; property DelErase; {Inherited events } property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnStartDrag; property OnEnter; property OnExit; property OnKeyDown; property OnKeyPress; property OnKeyUp; {Events } property OnGutterDraw; property OnGutterClick; property OnChange; property OnMoveCursor; property OnAttrChange; property OnSelectionChange; property OnStatusChange; property OnGetLineAttrs; property OnUndoChange; end; TGLSMemoStringList = class(TStringList) private procedure ReadStrings(Reader: TReader); procedure WriteStrings(Writer: TWriter); protected procedure DefineProperties(Filer: TFiler); override; end; TDelimiters = TSysCharSet; TTokenType = ( ttWord, ttBracket, ttSpecial, ttDelimiter, ttSpace, ttEOL, ttInteger, ttFloat, ttComment, ttOther, ttWrongNumber); //-------------------------------------------------------------- // SYNTAX MEMO - declaration //-------------------------------------------------------------- TGLSSynHiMemo = class(TGLSCustomMemo) private FIsPainting: Boolean; FInComment: Boolean; FWordList: TGLSMemoStringList; FSpecialList: TGLSMemoStringList; FBracketList: TGLSMemoStringList; FDelimiters: TDelimiters; FInBrackets: integer; FLineComment: string; FMultiCommentLeft: string; FMultiCommentRight: string; FDelimiterStyle: TCharStyle; FCommentStyle: TCharStyle; FNumberStyle: TCharStyle; FDelimiterStyleNo, FCommentStyleNo, FNumberStyleNo: integer; FCaseSensitive: Boolean; function GetToken(const S: string; var From: integer; out TokenType: TTokenType; out StyleNo: integer): string; procedure SetWordList(Value: TGLSMemoStringList); procedure SetSpecialList(Value: TGLSMemoStringList); procedure SetBracketList(Value: TGLSMemoStringList); procedure FindLineAttrs(Sender: TObject; LineNo: integer; var Attrs: string); procedure SetStyle(Index: integer; Value: TCharStyle); procedure SetCaseSensitive(Value: Boolean); protected procedure Paint; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure AddWord(StyleNo: integer; const ArrS: array of string); procedure AddSpecial(StyleNo: integer; const ArrS: array of string); procedure AddBrackets(StyleNo: integer; const ArrS: array of string); property Delimiters: TDelimiters read FDelimiters write FDelimiters; published {TControl} property PopupMenu; {TCustomControl} property Align; property Enabled; property ShowHint; property TabOrder; property TabStop; property Visible; property ReadOnly; {TGLSCustomMemo} property AutoIndent; property GutterColor; property GutterWidth; property ScrollBars; property Font; property BkColor; property SelColor; property SelBkColor; property Lines; property HiddenCaret; property TabSize; property ScrollMode; property UndoLimit; property DelErase; {Inherited events } property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnStartDrag; property OnEnter; property OnExit; property OnKeyDown; property OnKeyPress; property OnKeyUp; {Events } property OnGutterClick; property OnGutterDraw; property OnChange; property OnMoveCursor; property OnSelectionChange; property OnStatusChange; property OnUndoChange; {TGLSSyntaxMemo } property LineComment: string read FLineComment write FLineComment; property MultiCommentLeft: string read FMultiCommentLeft write FMultiCommentLeft; property MultiCommentRight: string read FMultiCommentRight write FMultiCommentRight; property WordList: TGLSMemoStringList read FWordList write SetWordList; property SpecialList: TGLSMemoStringList read FSpecialList write SetSpecialList; property BracketList: TGLSMemoStringList read FBracketList write SetBracketList; property DelimiterStyle: TCharStyle index 0 read FDelimiterStyle write SetStyle; property CommentStyle: TCharStyle index 1 read FCommentStyle write SetStyle; property NumberStyle: TCharStyle index 2 read FNumberStyle write SetStyle; property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; end; procedure Border(Canvas: TCanvas; const rct: TRect; BorderType: TBorderType); //========================================================== implementation //========================================================== const cmDelete = VK_DELETE; cmBackSpace = VK_BACK; cmWordBackSpace = 127; // Ctrl-BackSpace cmNewLine = VK_RETURN; cmHome = VK_HOME; cmEnd = VK_END; cmPageUp = VK_PRIOR; cmPageDown = VK_NEXT; cmInsert = VK_INSERT; cmDelLine = 25; // Ctrl-Y cmCopy = 3; // Ctrl-C cmCut = 24; // Ctrl-X cmPaste = 22; // Ctrl-V resourcestring SObjectsNotSupported = 'Linked object not supported'; var bmScrollBarFill: TBitmap; bmScrollBarUp: TBitmap; bmScrollBarDown: TBitmap; bmScrollBarLeft: TBitmap; bmScrollBarRight: TBitmap; fIntelliWheelSupport: Boolean; // True if IntelliMouse + wheel enabled fIntelliMessage: UINT; // message sent from mouse on wheel roll fIntelliScrollLines: Integer; // number of lines to scroll per wheel roll // ---------------------Helper functions function PointInRect(const P: TPoint; const rct: TRect): Boolean; inline; begin with rct do Result := (Left <= P.X) and (Top <= P.Y) and (Right >= P.X) and (Bottom >= P.Y); end; procedure Swap(var I1, I2: integer); inline; var temp: integer; begin temp := I1; I1 := I2; I2 := temp; end; procedure OrderPos(var StartX, StartY, EndX, EndY: integer); inline; begin if (EndY < StartY) or ((EndY = StartY) and (EndX < StartX)) then begin Swap(StartX, EndX); Swap(StartY, EndY); end; end; function TotalRect(const rct1, rct2: TRect): TRect; inline; begin Result := rct1; with Result do begin if rct2.Left < Left then Left := rct2.Left; if rct2.Top < Top then Top := rct2.Top; if rct2.Right > Right then Right := rct2.Right; if rct2.Bottom > Bottom then Bottom := rct2.Bottom; end; end; // ---------------------TGLSCustomMemo functions procedure TGLSCustomMemo.WndProc(var Message: TMessage); function GetShiftState: Integer; begin Result := 0; if GetAsyncKeyState(vk_Shift) < 0 then Result := Result or mk_Shift; if GetAsyncKeyState(vk_Control) < 0 then Result := Result or mk_Control; if GetAsyncKeyState(vk_LButton) < 0 then Result := Result or mk_LButton; if GetAsyncKeyState(vk_RButton) < 0 then Result := Result or mk_RButton; if GetAsyncKeyState(vk_MButton) < 0 then Result := Result or mk_MButton; end; //--------------------------------------------------- begin if (Message.Msg = fIntelliMessage) and (fIntelliMessage <> wm_MouseWheel) then begin PostMessage(Handle, wm_MouseWheel, MakeLong(GetShiftState, Message.wParam), Message.lParam); end else inherited; end; //------------------------------------------------ // INTELLIMOUSE INIT //------------------------------------------------ procedure IntelliMouseInit; var hWndMouse: hWnd; mQueryScrollLines: UINT; //-------------------------------------------- function NativeMouseWheelSupport: Boolean; var ver: TOSVersionInfo; begin Result := False; ver.dwOSVersionInfoSize := sizeof(ver); // For Windows 98, assume dwMajorVersion = 5 (It's 4 for W95) // For NT, we need 4.0 or better. if GetVersionEx(ver) then case ver.dwPlatformID of ver_Platform_Win32_Windows: Result := ver.dwMajorVersion >= 5; ver_Platform_Win32_NT: Result := ver.dwMajorVersion >= 4; end; { Quick and dirty temporary hack for Windows 98 beta 3 } if (not Result) and (ver.szCSDVersion = ' Beta 3') then Result := True; end; //-------------------------------------------- begin if NativeMouseWheelSupport then begin fIntelliWheelSupport := Boolean(GetSystemMetrics(sm_MouseWheelPresent)); SystemParametersInfo(spi_GetWheelScrollLines, 0, @fIntelliScrollLines, 0); fIntelliMessage := wm_MouseWheel; end else begin { Look for hidden mouse window } hWndMouse := FindWindow('MouseZ', 'Magellan MSWHEEL'); if hWndMouse <> 0 then begin { We're in business - get the scroll line info } fIntelliWheelSupport := True; mQueryScrollLines := RegisterWindowMessage('MSH_SCROLL_LINES_MSG'); fIntelliScrollLines := SendMessage(hWndMouse, mQueryScrollLines, 0, 0); { Finally, get the custom mouse message as well } fIntelliMessage := RegisterWindowMessage('MSWHEEL_ROLLMSG'); end; end; if (fIntelliScrollLines < 0) or (fIntelliScrollLines > 100) then fIntelliScrollLines := 3; end; //------------------------------------------------ // WM MOUSE WHEEL //------------------------------------------------ procedure TGLSCustomMemo.WMMouseWheel(var Message: TMessage); {$J+} {$IFOPT R+} {$DEFINE StoreRangeCheck} {$ENDIF} {$R-} const Delta: SmallInt = 0; begin Delta := Delta + SmallInt(HiWord(Message.wParam)); while Abs(Delta) >= 120 do begin if Delta < 0 then begin DoScroll(sbVert, fIntelliScrollLines); Delta := Delta + 120; end else begin DoScroll(sbVert, -fIntelliScrollLines); Delta := Delta - 120; end; end; end; {$J-} {$IFDEF StoreRangeCheck} {$R+} {$UNDEF StoreRangeCheck} {$ENDIF} //-------------------------------------------------------------- // SET CURSOR //-------------------------------------------------------------- procedure TGLSCustomMemo.SetCursor(ACurX, ACurY: Integer); begin ClearSelection; CurX := 0; CurY := ACurY; CurX := ACurX; end; //-------------------------------------------------------------- // SELECT LINE, CHAR //-------------------------------------------------------------- function TGLSCustomMemo.SelectLine(LineNo, StyleNo: Integer): integer; var rct: TRect; begin Result := LineStyle[LineNo]; LineStyle[LineNo] := StyleNo; rct := LineRect(LineNo); InvalidateRect(Handle, @rct, True); end; procedure TGLSCustomMemo.SelectLines(StartLine, EndLine: Integer); var rct: TRect; begin FSelStartX := 0; FSelStartY := StartLine; FSelEndX := Length(Lines[EndLine]); FSelEndY := EndLine; rct := LineRangeRect(FSelStartY, FSelEndY); SelectionChanged; InvalidateRect(Handle, @rct, true); end; procedure TGLSCustomMemo.SelectChar(LineNo, Pos, StyleNo: Integer); var rct: TRect; begin UnselectChar; FSelCharPos.LineNo := LineNo; FSelCharPos.Pos := Pos; FSelCharStyle := StyleNo; rct := LineRect(LineNo); InvalidateRect(Handle, @rct, True); end; procedure TGLSCustomMemo.UnSelectChar; var rct: TRect; begin with FSelCharPos do begin if LineNo < 0 then Exit; rct := LineRect(LineNo); LineNo := -1; Pos := -1; end; FSelCharStyle := -1; InvalidateRect(Handle, @rct, True); end; //-------------------------------------------------------------- // CLEAR //-------------------------------------------------------------- procedure TGLSCustomMemo.Clear; begin CurY := 0; CurX := 0; FLeftCol := 0; FTopLine := 0; Lines.Clear; TGLSMemoStrings(Lines).DoAdd(''); ClearUndoList; Invalidate; end; //-------------------------------------------------------------- // SELECT ALL //-------------------------------------------------------------- procedure TGLSCustomMemo.SelectAll; begin FSelStartY := 0; FSelStartX := 0; FSelEndY := Lines.Count - 1; FSelEndX := Length(Lines[Lines.Count - 1]); Invalidate; end; //----------------------------------------------------------- // SET CLIPBOARD CODE PAGE //----------------------------------------------------------- procedure SetClipboardCodePage(const CodePage: longint); var Data: THandle; DataPtr: Pointer; begin // Define new code page for clipboard Data := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, 4); try DataPtr := GlobalLock(Data); try Move(CodePage, DataPtr^, 4); SetClipboardData(CF_LOCALE, Data); finally GlobalUnlock(Data); end; except GlobalFree(Data); end; end; //-------------------------------------------------------------- // COPY TO CLIPBOARD //-------------------------------------------------------------- procedure CopyStringToClipboard(const Value: string); const RusLocale = (SUBLANG_DEFAULT shl $A) or LANG_RUSSIAN; begin Clipboard.Open; SetClipboardCodePage(RusLocale); try Clipboard.AsText := Value; finally SetClipboardCodePage(RusLocale); Clipboard.Close; end; end; procedure TGLSCustomMemo.CopyToClipBoard; begin CopyStringToClipboard(GetSelText); end; //-------------------------------------------------------------- // PASTE FROM CLIPBOARD //-------------------------------------------------------------- procedure TGLSCustomMemo.PasteFromClipBoard; var H, len: integer; Buff: string; begin H := ClipBoard.GetAsHandle(CF_TEXT); len := GlobalSize(H); if len = 0 then Exit; SetLength(Buff, len); SetLength(Buff, ClipBoard.GetTextBuf(PChar(Buff), len)); AdjustLineBreaks(Buff); SetSelText(Buff); end; //-------------------------------------------------------------- // DELETE SELECTION //-------------------------------------------------------------- procedure TGLSCustomMemo.DeleteSelection(bRepaint: Boolean); var xSelStartX, xSelStartY, xSelEndX, xSelEndY: integer; i, len: integer; OldX, OldY: integer; S1, S2, S, AddSpaces: string; Undo: TGLSMemoDeleteBufUndo; begin if (FSelStartY = FSelEndY) and (FSelStartX = FSelEndX) then Exit; OldX := CurX; OldY := CurY; xSelStartX := FSelStartX; xSelStartY := FSelStartY; xSelEndX := FSelEndX; xSelEndY := FSelEndY; OrderPos(xSelStartX, xSelStartY, xSelEndX, xSelEndY); if xSelStartY = xSelEndY then begin S1 := Copy(Lines[xSelStartY], xSelStartX + 1, xSelEndX - xSelStartX); S2 := ''; AddSpaces := ''; end else begin len := Length(Lines[xSelStartY]); S1 := Copy(Lines[xSelStartY], xSelStartX + 1, len); AddSpaces := StringOfChar(' ', xSelStartX - len); S2 := Copy(Lines[xSelEndY], 1, xSelEndX); end; Lines[xSelStartY] := Copy(Lines[xSelStartY], 1, xSelStartX) + AddSpaces + Copy(Lines[xSelEndY], xSelEndX + 1, Length(Lines[xSelEndY])); S := S1; for i := xSelStartY + 1 to xSelEndY do begin S := S + #13#10; if i <> xSelEndY then S := S + Lines[xSelStartY + 1]; DeleteLine(xSelStartY + 1, -1, -1, -1, -1, False); end; S := S + S2; CurY := xSelStartY; CurX := xSelStartX; ClearSelection; Changed(xSelStartY, -1); SelectionChanged; if bRepaint then Invalidate; Undo := TGLSMemoDeleteBufUndo.Create(OldX, OldY, CurX, CurY, S); Undo.UndoSelStartX := xSelStartX; Undo.UndoSelStartY := xSelStartY; Undo.UndoSelEndX := xSelEndX; Undo.UndoSelEndY := xSelEndY; if Assigned(FUndoList) then FUndoList.Add(Undo); end; //-------------------------------------------------------------- // CUT TO CLIPBOARD //-------------------------------------------------------------- procedure TGLSCustomMemo.CutToClipBoard; begin ClipBoard.SetTextBuf(PChar(GetSelText)); DeleteSelection(True); end; //-------------------------------------------------------------- // GET SEL TEXT //-------------------------------------------------------------- function TGLSCustomMemo.GetSelText: string; var i: integer; xSelStartX, xSelStartY, xSelEndX, xSelEndY: integer; begin Result := ''; if (FSelStartY = FSelEndY) and (FSelStartX = FSelEndX) then Exit; xSelStartX := FSelStartX; xSelStartY := FSelStartY; xSelEndX := FSelEndX; xSelEndY := FSelEndY; OrderPos(xSelStartX, xSelStartY, xSelEndX, xSelEndY); if xSelStartY = xSelEndY then Result := Copy(Lines[xSelStartY], xSelStartX + 1, xSelEndX - xSelStartX) else begin Result := Copy(Lines[xSelStartY], xSelStartX + 1, Length(Lines[xSelStartY])); for i := xSelStartY + 1 to xSelEndY - 1 do Result := Result + #13#10 + Lines[i]; Result := Result + #13#10 + Copy(Lines[xSelEndY], 1, xSelEndX); end; end; //-------------------------------------------------------------- // GET SEL START //-------------------------------------------------------------- function TGLSCustomMemo.GetSelStart: TPoint; var xSelStartX, xSelStartY, xSelEndX, xSelEndY: integer; begin xSelStartX := FSelStartX; xSelStartY := FSelStartY; xSelEndX := FSelEndX; xSelEndY := FSelEndY; OrderPos(xSelStartX, xSelStartY, xSelEndX, xSelEndY); Result := Point(xSelStartX, xSelStartY); end; //-------------------------------------------------------------- // GET SEL END //-------------------------------------------------------------- function TGLSCustomMemo.GetSelEnd: TPoint; var xSelStartX, xSelStartY, xSelEndX, xSelEndY: integer; begin xSelStartX := FSelStartX; xSelStartY := FSelStartY; xSelEndX := FSelEndX; xSelEndY := FSelEndY; OrderPos(xSelStartX, xSelStartY, xSelEndX, xSelEndY); Result := Point(xSelEndX, xSelEndY); end; //-------------------------------------------------------------- // SET SEL TEXT //-------------------------------------------------------------- procedure TGLSCustomMemo.SetSelText(const AValue: string); var i, k: integer; xSelStartX, xSelStartY, xSelEndX, xSelEndY: integer; Buff, S: string; OldX, OldY: integer; begin Buff := AValue; xSelStartX := FSelStartX; xSelStartY := FSelStartY; xSelEndX := FSelEndX; xSelEndY := FSelEndY; OrderPos(xSelStartX, xSelStartY, xSelEndX, xSelEndY); DeleteSelection(False); OldX := CurX; OldY := CurY; i := Pos(#13#10, Buff); S := Lines[xSelStartY]; if i = 0 then begin Lines[xSelStartY] := Copy(S, 1, xSelStartX) + Buff + Copy(S, xSelStartX + 1, Length(S)); CurX := xSelStartX; if Buff <> '' then CurX := CurX + Length(Buff); end else begin k := xSelStartY; Lines[k] := Copy(S, 1, xSelStartX) + Copy(Buff, 1, i - 1); TGLSMemoStrings(Lines).DoInsert(k + 1, Copy(S, xSelStartX + 1, Length(S))); while True do begin Buff := Copy(Buff, i + 2, Length(Buff)); i := Pos(#13#10, Buff); k := k + 1; if i = 0 then break; TGLSMemoStrings(Lines).DoInsert(k, Copy(Buff, 1, i - 1)); end; Lines[k] := Buff + Lines[k]; CurY := k; CurX := Length(Buff); end; ClearSelection; Changed(xSelStartY, -1); if Assigned(FUndoList) then FUndoList.Add(TGLSMemoPasteUndo.Create(OldX, OldY, CurX, CurY, AValue)); Invalidate; end; //-------------------------------------------------------------- // GET SEL LENGTH //-------------------------------------------------------------- function TGLSCustomMemo.GetSelLength: integer; begin Result := Length(GetSelText); end; //-------------------------------------------------------------- // CHANGED //-------------------------------------------------------------- procedure TGLSCustomMemo.Changed(FromLine, ToLine: integer); var i: integer; begin if ToLine < FromLine then ToLine := Lines.Count - 1; for i := FromLine to ToLine do ValidAttrs[i] := False; InvalidateLineRange(FromLine, ToLine); if Assigned(FOnChange) then FOnChange(Self); end; //-------------------------------------------------------------- // ATTR CHANGED //-------------------------------------------------------------- procedure TGLSCustomMemo.AttrChanged(LineNo: integer); begin ValidAttrs[LineNo] := False; InvalidateLineRange(LineNo, LineNo); if Assigned(FOnAttrChange) then FOnAttrChange(Self); end; //-------------------------------------------------------------- // SELECTION CHANGED //-------------------------------------------------------------- procedure TGLSCustomMemo.SelectionChanged; begin if Assigned(FOnSelectionChange) then FOnSelectionChange(Self); end; //-------------------------------------------------------------- // STATUS CHANGED //-------------------------------------------------------------- procedure TGLSCustomMemo.StatusChanged; begin if Assigned(FOnStatusChange) then FOnStatusChange(Self); end; //-------------------------------------------------------------- // CLEAR SELECTION //-------------------------------------------------------------- procedure TGLSCustomMemo.ClearSelection; var rct: TRect; Changed: Boolean; begin Changed := not ((FSelStartX = FSelEndX) and (FSelStartY = FSelEndY)); rct := LineRangeRect(FSelStartY, FSelEndY); FSelStartX := CurX; FSelStartY := CurY; FSelEndX := CurX; FSelEndY := CurY; FPrevSelX := CurX; FPrevSelY := CurY; if Changed then begin SelectionChanged; InvalidateRect(Handle, @rct, true); end; if Assigned(FOnMoveCursor) then FOnMoveCursor(Self); end; //-------------------------------------------------------------- // EXPAND SELECTION //-------------------------------------------------------------- procedure TGLSCustomMemo.ExpandSelection; var rct: TRect; begin rct := LineRangeRect(FPrevSelY, CurY); FSelEndX := CurX; FSelEndY := CurY; FPrevSelX := CurX; FPrevSelY := CurY; SelectionChanged; InvalidateRect(Handle, @rct, true); if Assigned(FOnMoveCursor) then FOnMoveCursor(Self); end; //-------------------------------------------------------------- // MAX LENGTH //-------------------------------------------------------------- function TGLSCustomMemo.MaxLength: integer; var i, len: integer; begin Result := 0; for i := 0 to Lines.Count - 1 do begin len := Length(Lines[i]); if len > Result then Result := len; end; end; //-------------------------------------------------------------- // DO SCROLL //-------------------------------------------------------------- procedure TGLSCustomMemo.DoScroll(Sender: TGLSMemoScrollBar; ByValue: integer); var eRect, scrRect, sbRect: TRect; Old: integer; begin eRect := EditorRect; case Sender.Kind of sbVertical: begin Old := FTopLine; FTopLine := FTopLine + ByValue; if FTopLine > Sender.MaxPosition then FTopLine := Sender.MaxPosition; if FTopLine < 0 then FTopLine := 0; if Old <> FTopLine then begin ShowCaret(False); if CurY < FTopLine then CurY := FTopLine; if CurY > LastVisibleLine then CurY := LastVisibleLine; ScrollDC(Canvas.Handle, 0, (Old - FTopLine) * FCellSize.H, eRect, eRect, 0, @scrRect); InvalidateRect(Handle, @scrRect, True); sbRect := Sender.FullRect; InvalidateRect(Handle, @sbRect, True); FGutter.Invalidate; ShowCaret(True); end; end; sbHorizontal: begin Old := FLeftCol; FLeftCol := FLeftCol + ByValue; if FLeftCol > Sender.MaxPosition then FLeftCol := Sender.MaxPosition; if FLeftCol < 0 then FLeftCol := 0; if Old <> FLeftCol then begin ShowCaret(False); if CurX < FLeftCol then CurX := FLeftCol; if CurX > LastVisiblePos then CurX := LastVisiblePos; ScrollDC(Canvas.Handle, (Old - FLeftCol) * FCellSize.W, 0, eRect, eRect, 0, @scrRect); InvalidateRect(Handle, @scrRect, True); sbRect := Sender.FullRect; InvalidateRect(Handle, @sbRect, True); ShowCaret(True); end; end; end; end; //-------------------------------------------------------------- // DO SCROLL PAGE //-------------------------------------------------------------- procedure TGLSCustomMemo.DoScrollPage(Sender: TGLSMemoScrollBar; ByValue: integer); begin case Sender.Kind of sbVertical: DoScroll(Sender, ByValue * VisibleLineCount); sbHorizontal: DoScroll(Sender, ByValue * VisiblePosCount); end; end; //-------------------------------------------------------------- // SET LINES //-------------------------------------------------------------- procedure TGLSCustomMemo.SetLines(ALines: TStrings); begin if ALines <> nil then begin FLines.Assign(ALines); Changed(0, -1); SelectionChanged; Invalidate; end; end; //-------------------------------------------------------------- // SET/GET LINE STYLE //-------------------------------------------------------------- procedure TGLSCustomMemo.SetLineStyle(Index: integer; Value: integer); begin TGLSMemoStrings(FLines).Style[Index] := Value; if IsLineVisible(Index) then AttrChanged(Index); end; function TGLSCustomMemo.GetLineStyle(Index: integer): integer; begin Result := TGLSMemoStrings(FLines).Style[Index]; end; //-------------------------------------------------------------- // GET/SET IN COMMENT //-------------------------------------------------------------- function TGLSCustomMemo.GetInComment(Index: integer): Boolean; begin Result := TGLSMemoStrings(FLines).InComment[Index]; end; procedure TGLSCustomMemo.SetInComment(Index: integer; Value: Boolean); begin TGLSMemoStrings(FLines).InComment[Index] := Value; end; //-------------------------------------------------------------- // GET/SET IN BRACKETS //-------------------------------------------------------------- function TGLSCustomMemo.GetInBrackets(Index: integer): integer; begin Result := TGLSMemoStrings(FLines).InBrackets[Index]; end; procedure TGLSCustomMemo.SetInBrackets(Index: integer; Value: integer); begin TGLSMemoStrings(FLines).InBrackets[Index] := Value; end; //-------------------------------------------------------------- // GET/SET VALID ATTRS //-------------------------------------------------------------- function TGLSCustomMemo.GetValidAttrs(Index: integer): Boolean; begin Result := TGLSMemoStrings(FLines).ValidAttrs[Index]; end; procedure TGLSCustomMemo.SetValidAttrs(Index: integer; Value: Boolean); begin TGLSMemoStrings(FLines).ValidAttrs[Index] := Value; end; //-------------------------------------------------------------- // GET/SET CHAR ATTRS //-------------------------------------------------------------- function TGLSCustomMemo.GetCharAttrs(Index: integer): string; begin Result := TGLSMemoStrings(FLines).CharAttrs[Index]; end; procedure TGLSCustomMemo.SetCharAttrs(Index: integer; const Value: string); begin TGLSMemoStrings(FLines).CharAttrs[Index] := Value; if IsLineVisible(Index) then AttrChanged(Index); end; //-------------------------------------------------------------- // SET CUR X //-------------------------------------------------------------- procedure TGLSCustomMemo.SetCurX(Value: integer); var len: integer; WasVisible: Boolean; begin if Value < 0 then if CurY = 0 then Value := 0 else begin CurY := CurY - 1; Value := Length(Lines[CurY]); end; if (CurY >= 0) and (CurY < Lines.Count) then begin len := Length(Lines[CurY]); if Value > len then begin Lines[CurY] := Lines[CurY] + StringOfChar(' ', Value - len); // Value := len; ValidAttrs[CurY] := False; InvalidateLineRange(CurY, CurY); end; end; FCurX := Value; WasVisible := FCaretVisible; if WasVisible then ShowCaret(False); MakeVisible; ResizeScrollBars; StatusChanged; if WasVisible then ShowCaret(True); end; //-------------------------------------------------------------- // SET CUR Y //-------------------------------------------------------------- procedure TGLSCustomMemo.SetCurY(Value: integer); var Old: integer; WasVisible: Boolean; begin WasVisible := FCaretVisible; if WasVisible then ShowCaret(False); Old := CurY; if Value < 0 then Value := 0; if Value >= Lines.Count then Value := Lines.Count - 1; FCurY := Value; if (CurY <> Old) and (Old >= 0) and (Old < Lines.Count) then Lines[Old] := TrimRight(Lines[Old]); CurX := CurX; MakeVisible; ResizeScrollBars; StatusChanged; if WasVisible then ShowCaret(True); end; //-------------------------------------------------------------- // MOVE CURSOR //-------------------------------------------------------------- procedure TGLSCustomMemo.MoveCursor(dX, dY: integer; Shift: TShiftState); var Selecting: Boolean; //------------------------------------------------------------ function IsDelimiter(c: char): Boolean; begin Result := Pos(c, ' .,;:/?!@#$%^&*(){}[]<>-+=|\') > 0; end; //------------------------------------------------------------ function IsStopChar(c, cThis: char): Boolean; begin Result := IsDelimiter(c) <> IsDelimiter(cThis); end; //------------------------------------------------------------ procedure MoveWordLeft; var S: string; begin CurX := CurX - 1; S := TrimRight(Lines[CurY]); while CurX > 0 do begin if IsStopChar(S[CurX], S[CurX + 1]) then break; CurX := CurX - 1; end; if (CurX < 0) then if CurY > 0 then begin CurY := CurY - 1; CurX := Length(Lines[CurY]); end; end; //------------------------------------------------------------ procedure MoveWordRight; var Len: integer; S: string; begin S := TrimRight(Lines[CurY]); Len := Length(S); CurX := CurX + 1; while CurX < Len do begin if IsStopChar(S[CurX + 1], S[CurX]) then break; CurX := CurX + 1; end; if CurX > Len then if CurY < Lines.Count - 1 then begin CurY := CurY + 1; CurX := 0; end; end; //------------------------------------------------------------ begin Selecting := (ssShift in Shift) and (CurX = FPrevSelX) and (CurY = FPrevSelY); if ssCtrl in Shift then begin if dX > 0 then MoveWordRight; if dX < 0 then MoveWordLeft; end else begin CurY := CurY + dY; CurX := CurX + dX; end; if Selecting then ExpandSelection else ClearSelection; end; //-------------------------------------------------------------- // MOVE PAGE //-------------------------------------------------------------- procedure TGLSCustomMemo.MovePage(dP: integer; Shift: TShiftState); var eRect: TRect; LinesPerPage: integer; Selecting: Boolean; begin if FCellSize.H = 0 then Exit; Selecting := (ssShift in Shift) and (CurX = FPrevSelX) and (CurY = FPrevSelY); eRect := EditorRect; LinesPerPage := (eRect.Bottom - eRect.Top) div FCellSize.H - 1; CurY := CurY + dP * LinesPerPage; if ssCtrl in Shift then if dP > 0 then begin CurY := Lines.Count - 1; CurX := Length(Lines[Lines.Count - 1]); end else begin CurY := 0; CurX := 0; end; if Selecting then ExpandSelection else ClearSelection; end; //-------------------------------------------------------------- // GO HOME //-------------------------------------------------------------- procedure TGLSCustomMemo.GoHome(Shift: TShiftState); var Selecting: Boolean; begin Selecting := (ssShift in Shift) and (CurX = FPrevSelX) and (CurY = FPrevSelY); CurX := 0; FLeftCol := 0; if Selecting then ExpandSelection else ClearSelection; end; //-------------------------------------------------------------- // GO END //-------------------------------------------------------------- procedure TGLSCustomMemo.GoEnd(Shift: TShiftState); var Selecting: Boolean; S, S1: string; begin Selecting := (ssShift in Shift) and (CurX = FPrevSelX) and (CurY = FPrevSelY); S := Lines[CurY]; if not Selecting then S := TrimRight(S); S1 := TrimRight(Copy(S, CurX + 1, Length(S))); S := Copy(S, 1, CurX); Lines[CurY] := S + S1; CurX := Length(Lines[CurY]); if Selecting then ExpandSelection else ClearSelection; end; //-------------------------------------------------------------- // INSERT CHAR //-------------------------------------------------------------- procedure TGLSCustomMemo.InsertChar(C: Char); var S, S1: string; NewPlace: integer; rct: TRect; CurX0, CurY0: integer; begin CurX0 := CurX; CurY0 := CurY; S := Lines[CurY]; NewPlace := CurX + 1; if C = #9 then begin while (NewPlace mod TabSize) <> 0 do Inc(NewPlace); S1 := StringOfChar(' ', NewPlace - CurX); end else S1 := C; Insert(S1, S, CurX + 1); Lines[CurY] := S; CurX := NewPlace; ClearSelection; rct := LineRect(CurY); Changed(CurY, CurY); if Assigned(FUndoList) then FUndoList.Add(TGLSMemoInsCharUndo.Create(CurX0, CurY0, CurX, CurY, S1)); InvalidateRect(Handle, @rct, True); end; //-------------------------------------------------------------- // INSERT TEMPLATE //-------------------------------------------------------------- procedure TGLSCustomMemo.InsertTemplate(AText: string); var i, NewCurX, NewCurY: integer; Indent: string; FoundCursor: Boolean; begin Indent := IndentCurrLine; DeleteSelection(False); ClearSelection; NewCurX := CurX; NewCurY := CurY; FoundCursor := False; i := 1; while i <= Length(AText) do begin if AText[i] = #13 then begin if (i = Length(AText)) or (AText[i + 1] <> #10) then Insert(#10 + Indent, AText, i + 1); if not FoundCursor then begin Inc(NewCurY); NewCurX := Length(Indent); end; Inc(i, 1 + Length(Indent)); end else if AText[i] = #7 then begin FoundCursor := True; Delete(AText, i, 1); Dec(i); end else if Ord(AText[i]) < Ord(' ') then begin Delete(AText, i, 1); Dec(i); end else if not FoundCursor then Inc(NewCurX); Inc(i); end; SetSelText(AText); SetCursor(NewCurX, NewCurY); ClearSelection; try SetFocus; except end; end; //-------------------------------------------------------------- // DELETE CHAR //-------------------------------------------------------------- procedure TGLSCustomMemo.DeleteChar(OldX, OldY: integer); var S, S1: string; rct: TRect; C: char; Undo: TGLSMemoDelCharUndo; IsBackspace: Boolean; begin if FReadOnly then Exit; if OldX < 0 then begin OldX := CurX; OldY := CurY; IsBackspace := False; end else IsBackspace := True; ClearSelection; S := Lines[CurY]; S1 := Copy(S, CurX + 1, Length(S)); if not IsBackspace then S1 := TrimRight(S1); S := Copy(S, 1, CurX); Lines[CurY] := S + S1; if CurX < Length(Lines[CurY]) then begin S := Lines[CurY]; C := S[CurX + 1]; Delete(S, CurX + 1, 1); Lines[CurY] := S; Changed(CurY, CurY); rct := LineRect(CurY); Undo := TGLSMemoDelCharUndo.Create(OldX, OldY, CurX, CurY, C); Undo.IsBackSpace := IsBackSpace; if Assigned(FUndoList) then FUndoList.Add(Undo); end else if CurY < Lines.Count - 1 then begin S := Lines[CurY] + Lines[CurY + 1]; Lines[CurY] := S; DeleteLine(CurY + 1, OldX, OldY, CurX, CurY, False); Changed(CurY, -1); rct := EditorRect; Undo := TGLSMemoDelCharUndo.Create(OldX, OldY, CurX, CurY, #13); Undo.IsBackSpace := IsBackSpace; if Assigned(FUndoList) then FUndoList.Add(Undo); end; ClearSelection; InvalidateRect(Handle, @rct, True); end; //-------------------------------------------------------------- // DELETE LINE //-------------------------------------------------------------- procedure TGLSCustomMemo.DeleteLine(Index, OldX, OldY, NewX, NewY: integer; FixUndo: Boolean); var rct: TRect; s: string; begin if Index < 0 then Index := CurY; if OldX < 0 then begin OldX := CurX; OldY := CurY; end; s := Lines[Index]; TGLSMemoStrings(Lines).FDeleting := True; if Lines.Count = 1 then TGLSMemoStrings(Lines)[0] := '' else Lines.Delete(Index); TGLSMemoStrings(Lines).FDeleting := False; ClearSelection; if Index >= Lines.Count then Changed(Index - 1, -1) else Changed(Index, -1); rct := EditorRect; InvalidateRect(Handle, @rct, True); if NewX < 0 then begin if Length(Lines[0]) < CurX then CurX := Length(Lines[0]); if Index >= Lines.Count then CurY := Index - 1 else CurY := Index; NewX := CurX; NewY := CurY; end else begin CurX := NewX; CurY := NewY; end; if Assigned(FUndoList) and FixUndo then FUndoList.Add(TGLSMEmoDelLineUndo.Create(Index, OldX, OldY, NewX, NewY, s)); end; //-------------------------------------------------------------- // BACK SPACE //-------------------------------------------------------------- procedure TGLSCustomMemo.BackSpace; var OldX, OldY: integer; begin OldX := CurX; OldY := CurY; MoveCursor(-1, 0, []); if (OldX = CurX) and (OldY = CurY) then Exit; DeleteChar(OldX, OldY); end; //-------------------------------------------------------------- // BACK SPACE WORD //-------------------------------------------------------------- procedure TGLSCustomMemo.BackSpaceWord; begin ClearSelection; MoveCursor(-1, 0, [ssShift, ssCtrl]); DeleteSelection(True); end; //-------------------------------------------------------------- // INDENT CURR LINE //-------------------------------------------------------------- function TGLSCustomMemo.IndentCurrLine: string; var Len, Count: integer; CurS: string; begin Result := ''; if not AutoIndent then Exit; CurS := Lines[CurY]; Len := Length(CurS); Count := 0; while (Count < CurX) and (Count < Len) do begin if CurS[Count + 1] <> ' ' then break; Inc(Count); end; Result := StringOfChar(' ', Count); end; //-------------------------------------------------------------- // NEW LINE //-------------------------------------------------------------- procedure TGLSCustomMemo.NewLine; var S, sIndent: string; OldX, OldY: integer; begin OldX := CurX; OldY := CurY; S := Lines[CurY]; sIndent := IndentCurrLine; Lines[CurY] := Copy(S, 1, CurX); S := TrimRight(Copy(S, CurX + 1, Length(S))); if AutoIndent then while (Length(S) > 0) and (S[1] = ' ') do Delete(S, 1, 1); TGLSMemoStrings(Lines).DoInsert(CurY + 1, sIndent + S); GoHome([]); MoveCursor(0, 1, []); CurX := Length(sIndent); ClearSelection; if Assigned(FUndoList) then FUndoList.Add(TGLSMemoInsCharUndo.Create(OldX, OldY, CurX, CurY, #13 + sIndent)); Invalidate; Changed(CurY - 1, -1); end; //-------------------------------------------------------------- // ADD STRING //-------------------------------------------------------------- function TGLSCustomMemo.AddString(const S: string): integer; begin if Lines.Count = 0 then TGLSMemoStrings(Lines).DoAdd(''); MovePage(1, [ssCtrl]); // end of text if not ((Lines.Count = 1) and (Lines[0] = '')) then begin TGLSMemoStrings(Lines).DoAdd(''); CurX := 0; CurY := Lines.Count; ClearSelection; // S := #13#10 + S; end; SetSelText(S); Result := Lines.Count - 1; end; //-------------------------------------------------------------- // INSERT STRING //-------------------------------------------------------------- procedure TGLSCustomMemo.InsertString(Index: integer; S: string); begin CurY := Index; CurX := 0; ClearSelection; if not ((Lines.Count = 1) and (Lines[0] = '')) then S := S + #13#10; SetSelText(S); end; //-------------------------------------------------------------- // DO COMMAND //-------------------------------------------------------------- procedure TGLSCustomMemo.DoCommand(cmd: TCommand; const AShift: TShiftState); begin case cmd of cmDelete: if not FReadOnly then begin if ssShift in AShift then CutToClipboard else if FDelErase and (not ((FSelStartX = FSelEndX) and (FSelStartY = FSelEndY))) then DeleteSelection(True) else DeleteChar(-1, -1); end; cmBackSpace: BackSpace; cmWordBackSpace: BackSpaceWord; cmNewLine: NewLine; cmDelLine: DeleteLine(-1, -1, -1, -1, -1, True); cmCopy: CopyToClipboard; cmCut: CutToClipboard; cmPaste: PasteFromClipboard; cmHome: GoHome(AShift); cmEnd: GoEnd(AShift); cmPageDown: MovePage(1, AShift); cmPageUp: MovePage(-1, AShift); cmInsert: begin if ssShift in AShift then PasteFromClipboard; if ssCtrl in AShift then CopyToClipboard; end; end; end; //-------------------------------------------------------------- // KEY DOWN //-------------------------------------------------------------- procedure TGLSCustomMemo.KeyDown(var Key: Word; Shift: TShiftState); begin ShowCaret(False); inherited; case Key of VK_LEFT: MoveCursor(-1, 0, Shift); VK_RIGHT: MoveCursor(1, 0, Shift); VK_UP: MoveCursor(0, -1, Shift); VK_DOWN: MoveCursor(0, 1, Shift); VK_HOME, VK_END, VK_DELETE: DoCommand(Key, Shift); VK_PRIOR, VK_NEXT: DoCommand(Key, Shift); VK_INSERT: DoCommand(Key, Shift); end; ShowCaret(True); end; //-------------------------------------------------------------- // KEY PRESS //-------------------------------------------------------------- procedure TGLSCustomMemo.KeyPress(var Key: Char); begin if FReadOnly then Exit; ShowCaret(False); inherited; if (ord(Key) in [9, 32..255]) and (ord(Key) <> 127) then begin if FDelErase and (not ((FSelStartX = FSelEndX) and (FSelStartY = FSelEndY))) then DeleteSelection(True); InsertChar(Key); end else DoCommand(Ord(Key), []); ShowCaret(True); end; //-------------------------------------------------------------- // MOUSE DOWN //-------------------------------------------------------------- procedure TGLSCustomMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var newPos: TCellPos; charPos: TFullPos; Selecting: Boolean; begin inherited; if not Focused then begin SetFocus; // Exit; end; if FAfterDoubleClick then begin FAfterDoubleClick := False; Exit; end; if Button <>mbLeft then Exit; if sbVert.MouseDown(Button, Shift, X, Y) then Exit; if sbHorz.MouseDown(Button, Shift, X, Y) then Exit; if PointInRect(Point(X, Y), EditorRect) then begin ShowCaret(False); newPos := CellFromPos(X, Y); CurY := newPos.Y + FTopLine; CurX := newPos.X + FLeftCol; if Assigned(FOnMoveCursor) then FOnMoveCursor(Self); Selecting := ssShift in Shift; if Button = mbLeft then begin if Selecting then ExpandSelection else ClearSelection; FLeftButtonDown := True; end else ShowCaret(True); end; if Assigned(FOnGutterClick) then if PointInRect(Point(X, Y), FGutter.FullRect) then begin charPos := CharFromPos(X, Y); if charPos.LineNo < Lines.Count then FOnGutterClick(Self, charPos.LineNo); end; end; //-------------------------------------------------------------- // MOUSE MOVE //-------------------------------------------------------------- procedure TGLSCustomMemo.MouseMove(Shift: TShiftState; X, Y: Integer); var newPos: TCellPos; begin inherited; if sbVert.MouseMove(Shift, X, Y) then Exit; if sbHorz.MouseMove(Shift, X, Y) then Exit; if PointInRect(Point(X, Y), EditorRect) then begin if (ssLeft in Shift) and FLeftButtonDown then begin newPos := CellFromPos(X, Y); CurY := newPos.Y + FTopLine; CurX := newPos.X + FLeftCol; ExpandSelection; end; end end; //-------------------------------------------------------------- // MOUSE UP //-------------------------------------------------------------- procedure TGLSCustomMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; if sbVert.MouseUp(Button, Shift, X, Y) then Exit; if sbHorz.MouseUp(Button, Shift, X, Y) then Exit; if Button = mbLeft then ShowCaret(True); FLeftButtonDown := False; FLastMouseUpX := X; FLastMouseUpY := Y; end; //-------------------------------------------------------------- // DBL CLICK //-------------------------------------------------------------- procedure TGLSCustomMemo.DblClick; var clickPos: TCellPos; clickX, clickY: integer; //------------------------------------------------------------ // SELECT WORD //------------------------------------------------------------ procedure SelectWord; const stopChars: TSysCharSet = [' ', ';', '.', ',', ':', '?', '!', '''', '"', '<', '>', '/', '*', '+', '-', '=', '(', ')', '[', ']', '{', '}', '@', '#', '$', '%', '^', '&', '|', '\']; var s: string; i: integer; rct: TRect; begin CurX := clickX; CurY := clickY; if (CurX = clickX) and (CurY = clickY) then begin s := Lines[clickY]; if s[clickX + 1] = ' ' then Exit; i := clickX; while (i >= 0) and not CharInSet(s[i + 1], stopChars) do Dec(i); FSelStartY := clickY; FSelStartX := i + 1; i := clickX; while (i < Length(s)) and not CharInSet(s[i + 1], stopChars) do Inc(i); FSelEndY := clickY; FSelEndX := i; if FSelEndX <> FSelStartX then begin FAfterDoubleClick := True; rct := LineRangeRect(CurY, CurY); SelectionChanged; InvalidateRect(Handle, @rct, true); end; end; end; //------------------------------------------------------------ begin if PointInRect(Point(FLastMouseUpX, FLastMouseUpY), EditorRect) then begin clickPos := CellFromPos(FLastMouseUpX, FLastMouseUpY); clickX := clickPos.X + FLeftCol; clickY := clickPos.Y + FTopLine; SelectWord; end; inherited; end; //-------------------------------------------------------------- // WM_GETDLGCODE //-------------------------------------------------------------- procedure TGLSCustomMemo.WMGetDlgCode(var Msg: TWMGetDlgCode); begin Msg.Result := DLGC_WANTARROWS or DLGC_WANTTAB; end; //-------------------------------------------------------------- // WM_ERASEBKGND //-------------------------------------------------------------- procedure TGLSCustomMemo.WMEraseBkgnd(var Msg: TWmEraseBkgnd); begin Msg.Result := 1; end; //-------------------------------------------------------------- // WM_SIZE //-------------------------------------------------------------- procedure TGLSCustomMemo.WMSize(var Msg: TWMSize); begin if not (csLoading in ComponentState) then try ResizeEditor; except end; end; //-------------------------------------------------------------- // WM_SETCURSOR //-------------------------------------------------------------- procedure TGLSCustomMemo.WMSetCursor(var Msg: TWMSetCursor); var P: TPoint; begin Msg.Result := 1; GetCursorPos(P); P := ScreenToClient(P); if PointInRect(P, EditorRect) then Winapi.Windows.SetCursor(Screen.Cursors[crIBeam]) else Winapi.Windows.SetCursor(Screen.Cursors[crArrow]); end; //-------------------------------------------------------------- // WM_SETFOCUS //-------------------------------------------------------------- procedure TGLSCustomMemo.WMSetFocus(var Msg: TWMSetFocus); begin if FCellSize.H = 0 then SetFont(FFont); CreateCaret(Handle, HBITMAP(0), 2, FCellSize.H - 2); ShowCaret(true); end; //-------------------------------------------------------------- // WM_KILLFOCUS //-------------------------------------------------------------- procedure TGLSCustomMemo.WMKillFocus(var Msg: TWMSetFocus); begin DestroyCaret; FCaretVisible := False; inherited; end; //-------------------------------------------------------------- // SHOW CARET //-------------------------------------------------------------- procedure TGLSCustomMemo.ShowCaret(State: Boolean); var rct: TRect; begin FCaretVisible := False; if not State then HideCaret(Handle) else if Focused and not HiddenCaret then begin rct := CellRect(CurX - FLeftCol, CurY - FTopLine); SetCaretPos(rct.Left, rct.Top + 1); Winapi.Windows.ShowCaret(Handle); FCaretVisible := True; end; end; //-------------------------------------------------------------- // CELL RECT //-------------------------------------------------------------- function TGLSCustomMemo.CellRect(ACol, ARow: integer): TRect; var rct: TRect; begin rct := EditorRect; with FCellSize do Result := Rect(rct.Left + W * ACol, rct.Top + H * ARow, rct.Left + W * (ACol + 1), rct.Top + H * (ARow + 1)); end; //-------------------------------------------------------------- // LINE RECT //-------------------------------------------------------------- function TGLSCustomMemo.LineRect(ARow: integer): TRect; var rct: TRect; begin rct := EditorRect; ARow := ARow - FTopLine; with FCellSize do Result := Rect(rct.Left, rct.Top + H * ARow, rct.Right, rct.Top + H * (ARow + 1)); end; //-------------------------------------------------------------- // COL RECT //-------------------------------------------------------------- function TGLSCustomMemo.ColRect(ACol: integer): TRect; var rct: TRect; begin rct := EditorRect; ACol := ACol - FLeftCol; with FCellSize do Result := Rect(rct.Left + W * ACol, rct.Top, rct.Left + W * (ACol + 1), rct.Bottom); end; //-------------------------------------------------------------- // LINE RANGE RECT //-------------------------------------------------------------- function TGLSCustomMemo.LineRangeRect(FromLine, ToLine: integer): TRect; var rct1, rct2: TRect; begin rct1 := LineRect(FromLine); rct2 := LineRect(ToLine); Result := TotalRect(rct1, rct2); end; //-------------------------------------------------------------- // INVALIDATE LINE RANGE //-------------------------------------------------------------- procedure TGLSCustomMemo.InvalidateLineRange(FromLine, ToLine: integer); var rct: TRect; begin if ToLine < FromLine then ToLine := Lines.Count - 1; rct := LineRangeRect(FromLine, ToLine); if GutterWidth > 2 then rct.Left := FGutter.Left; InvalidateRect(Handle, @rct, True); end; //-------------------------------------------------------------- // COL RANGE RECT //-------------------------------------------------------------- function TGLSCustomMemo.ColRangeRect(FromCol, ToCol: integer): TRect; var rct1, rct2: TRect; begin rct1 := ColRect(FromCol); rct2 := ColRect(ToCol); Result := TotalRect(rct1, rct2); end; //-------------------------------------------------------------- // CELL and CHAR FROM POS //-------------------------------------------------------------- function TGLSCustomMemo.CellFromPos(X, Y: integer): TCellPos; var rct: TRect; begin rct := EditorRect; if (FCellSize.H = 0) and Assigned(FFont) then SetFont(FFont); if (FCellSize.W <> 0) and (FCellSize.H <> 0) then begin Result.X := (X - rct.Left) div FCellSize.W; Result.Y := (Y - rct.Top) div FCellSize.H; end else begin Result.X := 0; Result.Y := 0; end; end; function TGLSCustomMemo.CharFromPos(X, Y: integer): TFullPos; var rct: TRect; begin rct := EditorRect; if (FCellSize.H = 0) and Assigned(FFont) then SetFont(FFont); if (FCellSize.W <> 0) and (FCellSize.H <> 0) then begin Result.Pos := (X - rct.Left) div FCellSize.W + FLeftCol; Result.LineNo := (Y - rct.Top) div FCellSize.H + FTopLine; end else begin Result.Pos := 1; Result.LineNo := 1; end; end; //-------------------------------------------------------------- // SET COLOR //-------------------------------------------------------------- procedure TGLSCustomMemo.SetColor(Index: integer; Value: TColor); var eRect: TRect; Changed: Boolean; begin Changed := False; case Index of 0: if FBkColor <> Value then begin FBkColor := Value; FStyles.BkColor[0] := Value; Changed := True; end; 1: if FSelColor <> Value then begin FSelColor := Value; Changed := True; end; 2: if FSelBkColor <> Value then begin FSelBkColor := Value; Changed := True; end; end; if Changed then begin eRect := EditorRect; InvalidateRect(Handle, @eRect, True); end; end; //-------------------------------------------------------------- // SET FONT //-------------------------------------------------------------- procedure TGLSCustomMemo.SetFont(Value: TFont); var wW, wi: integer; OldFontName: string; eRect: TRect; begin OldFontName := Canvas.Font.Name; Canvas.Font.Name := Value.Name; wW := Canvas.TextWidth('W'); wi := Canvas.TextWidth('i'); Canvas.Font.Name := OldFontName; if wW <> wi then raise EAbort.Create('Monospace font required'); FFont.Assign(Value); Canvas.Font.Assign(Value); FCellSize.W := Canvas.TextWidth('W'); FCellSize.H := Canvas.TextHeight('W') + 1; if FCaretVisible then begin ShowCaret(False); DestroyCaret; CreateCaret(Handle, HBITMAP(0), 2, FCellSize.H - 2); ShowCaret(true); end; FStyles.TextColor[0] := FFont.Color; FStyles.Style[0] := FFont.Style; eRect := EditorRect; InvalidateRect(Handle, @eRect, True); end; //-------------------------------------------------------------- // SET GUTTER WIDTH //-------------------------------------------------------------- procedure TGLSCustomMemo.SetGutterWidth(Value: integer); begin FGutterWidth := Value; FGutter.FWidth := Value; if not (csLoading in ComponentState) then ResizeEditor; end; //-------------------------------------------------------------- // SET GUTTER COLOR //-------------------------------------------------------------- procedure TGLSCustomMemo.SetGutterColor(Value: TColor); begin if FGutter.FColor <> Value then begin FGutter.FColor := Value; FGutter.Invalidate; end; end; //-------------------------------------------------------------- // GET GUTTER COLOR //-------------------------------------------------------------- function TGLSCustomMemo.GetGutterColor: TColor; begin Result := FGutter.FColor; end; //-------------------------------------------------------------- // CHAR STYLE NO //-------------------------------------------------------------- function TGLSCustomMemo.CharStyleNo(LineNo, Pos: integer): integer; var ChStyle: string; begin Result := 0; if (LineNo < 0) or (LineNo >= Lines.Count) then Exit; ChStyle := CharAttrs[LineNo]; if (Pos <= 0) or (Pos > Length(ChStyle)) then Exit; Result := integer(ChStyle[Pos]); end; //-------------------------------------------------------------- // DRAW LINE //-------------------------------------------------------------- procedure TGLSCustomMemo.DrawLine(LineNo: integer); var eRect, rct0, rct1, rct, lineRct: TRect; LineSelStart, LineSelEnd, LineStyleNo, pos: integer; S, S1, S2, S3, ChStyle: string; //--------- FIND LINE SELECTION ------------- procedure FindLineSelection; var len: integer; xSelStartX, xSelStartY, xSelEndX, xSelEndY: integer; begin xSelStartX := FSelStartX; xSelStartY := FSelStartY; xSelEndX := FSelEndX; xSelEndY := FSelEndY; OrderPos(xSelStartX, xSelStartY, xSelEndX, xSelEndY); len := Length(Lines[LineNo]); LineSelStart := 0; LineSelEnd := 0; if xSelStartY = Lineno then begin LineSelStart := xSelStartX - FLeftCol; LineSelEnd := len - FLeftCol; end else if (xSelStartY < LineNo) and (LineNo < xSelEndY) then begin LineSelStart := 0; LineSelEnd := len - FLeftCol; end; if xSelEndY = LineNo then LineSelEnd := xSelEndX - FLeftCol; if LineSelEnd < LineSelStart then Swap(LineSelEnd, LineSelStart); if LineSelStart < 0 then LineSelStart := 0; S := Copy(Lines[LineNo], FLeftCol + 1, len); S1 := Copy(S, 1, LineSelStart); S2 := Copy(S, LineSelStart + 1, LineSelEnd - LineSelStart); S3 := Copy(S, LineSelEnd + 1, len); end; //------------- DRAW PART --------------------- procedure DrawPart(const Part: string; PartStyle, StartPos: integer; var rct: TRect; IsSelection: Boolean); var len, w: integer; rctInternal: TRect; begin len := Length(Part); if len > 0 then with FLineBitmap.Canvas do begin w := FCellSize.W * len; Font.Style := FStyles.Style[PartStyle]; if IsSelection then begin Font.Color := SelColor; Brush.Color := SelBkColor; end else begin if LineStyleNo = 0 then begin Font.Color := FStyles.TextColor[PartStyle]; Brush.Color := FStyles.BkColor[PartStyle]; end else begin if (LineNo = FSelCharPos.LineNo) and (StartPos = FSelCharPos.Pos + 1) and (Length(Part) = 1) then begin Font.Color := FStyles.TextColor[PartStyle]; Brush.Color := FStyles.BkColor[PartStyle]; end else begin Font.Color := FStyles.TextColor[LineStyleNo]; Brush.Color := FStyles.BkColor[LineStyleNo]; Font.Style := FStyles.Style[LineStyleNo]; end; end; end; rct.Right := rct.Left + w; rctInternal := rct; rctInternal.Left := rctInternal.Left - eRect.Left; rctInternal.Right := rctInternal.Right - eRect.Left; rctInternal.Top := rctInternal.Top - rct.Top; rctInternal.Bottom := rctInternal.Bottom - rct.Top; FillRect(rctInternal); DrawText(Handle, PChar(Part), len, rctInternal, DT_LEFT or DT_SINGLELINE or DT_NOPREFIX); rct0.Left := rct.Left + w; rct := rct0; end; end; //------------- DRAW SEGMENTS --------------------- procedure DrawSegments(S: string; WorkPos: integer; var rct: TRect; IsSelection: Boolean); var i, len, ThisStyle: integer; begin while True do begin Len := Length(S); if Len = 0 then Exit; ThisStyle := Ord(ChStyle[WorkPos]); i := 1; while (i <= Len) and (ThisStyle = Ord(ChStyle[WorkPos + i - 1])) do Inc(i); DrawPart(Copy(S, 1, i - 1), ThisStyle, WorkPos, rct, IsSelection); Inc(WorkPos, i - 1); s := Copy(s, i, Len); end; end; //--------------------------------------------- begin eRect := EditorRect; rct := CellRect(0, LineNo - FTopLine); rct0 := Rect(eRect.Left, rct.Top, eRect.Right, rct.Bottom); lineRct := rct0; if LineNo < Lines.Count then begin rct := rct0; S := Lines[LineNo]; LineStyleNo := LineStyle[LineNo]; ChStyle := CharAttrs[LineNo]; FindLineSelection; if not Assigned(FOnGetLineAttrs) then ChStyle := StringOfChar(#0, Length(Lines[LineNo])); if Length(S) > 0 then if (FSelCharStyle >= 0) and (LineNo = FSelCharPos.LineNo) then ChStyle[FSelCharPos.Pos + 1] := Char(FSelCharStyle); pos := FLeftCol + 1; // 1 DrawSegments(S1, pos, rct, False); Inc(pos, Length(S1)); DrawSegments(S2, pos, rct, True); Inc(pos, Length(S2)); DrawSegments(S3, pos, rct, False); // else begin // DrawPart(S1,StyleNo,rct,False); // DrawPart(S2,StyleNo,rct,True); // DrawPart(S3,StyleNo,rct,False); // end; rct1 := rct; rct1.Left := rct1.Left - eRect.Left; rct1.Right := rct1.Right - eRect.Left; rct1.Top := rct1.Top - rct.Top; rct1.Bottom := rct1.Bottom - rct.Top; with FLineBitmap.Canvas do begin Brush.Color := FStyles.BkColor[LineStyleNo]; FillRect(rct1); end; with LineRct do BitBlt(Canvas.Handle, Left, Top, Right - Left, Bottom - Top, FLineBitmap.Canvas.Handle, 0, 0, SRCCOPY); end else with Canvas do begin Brush.Color := BkColor; FillRect(rct0); end; end; //-------------------------------------------------------------- // SET HIDDEN CARET //-------------------------------------------------------------- procedure TGLSCustomMemo.SetHiddenCaret(Value: Boolean); begin if Value <> FHiddenCaret then begin FHiddenCaret := Value; if Focused then if FHiddenCaret = FCaretVisible then ShowCaret(not FHiddenCaret); end; end; //-------------------------------------------------------------- // BORDER //-------------------------------------------------------------- procedure Border(Canvas: TCanvas; const rct: TRect; BorderType: TBorderType); const Colors: array[TBorderType] of array[1..4] of TColor = (($D0D0D0, clWhite, clGray, clBlack), (clGray, clBlack, $D0D0D0, clWhite), (clWhite, clWhite, clWhite, clGray), (clGray, clWhite, clWhite, clGray)); begin with Canvas do begin Pen.Color := Colors[BorderType][1]; MoveTo(rct.Left, rct.Bottom - 1); LineTo(rct.Left, rct.Top); LineTo(rct.Right, rct.Top); if BorderType in [btRaised, btLowered] then begin Pen.Color := Colors[BorderType][2]; MoveTo(rct.Left + 1, rct.Bottom); LineTo(rct.Left + 1, rct.Top + 1); LineTo(rct.Right, rct.Top + 1); Pen.Color := Colors[BorderType][3]; MoveTo(rct.Left + 1, rct.Bottom - 2); LineTo(rct.Right - 2, rct.Bottom - 2); LineTo(rct.Right - 2, rct.Top + 1); end; Pen.Color := Colors[BorderType][4]; MoveTo(rct.Left, rct.Bottom - 1); LineTo(rct.Right - 1, rct.Bottom - 1); LineTo(rct.Right - 1, rct.Top); end; end; //-------------------------------------------------------------- // EDITOR RECT //-------------------------------------------------------------- function TGLSCustomMemo.EditorRect: TRect; var l, t, r, b: integer; begin l := 2; r := Width - 2; t := 2; b := Height - 2; if GutterWidth > 2 then l := l + GutterWidth; if FScrollBars in [ssBoth, ssVertical] then r := r - FScrollBarWidth; if FScrollBars in [ssBoth, ssHorizontal] then b := b - FScrollBarWidth; Result := Rect(l + FMargin, t, r, b); end; //-------------------------------------------------------------- // DRAW MARGIN //-------------------------------------------------------------- procedure TGLSCustomMemo.DrawMargin; var eRect: TRect; i: integer; begin eRect := EditorRect; with Canvas do begin Pen.Color := clWhite; for i := 1 to FMargin do begin MoveTo(eRect.Left - i, eRect.Top); LineTo(eRect.Left - i, eRect.Bottom + 1); end; end; end; //-------------------------------------------------------------- // DRAW GUTTER //-------------------------------------------------------------- procedure TGLSCustomMemo.DrawGutter; begin if GutterWidth < 2 then Exit; ResizeGutter; FGutter.PaintTo(Canvas); end; //-------------------------------------------------------------- // DRAW SCROLLBARS //-------------------------------------------------------------- procedure TGLSCustomMemo.DrawScrollBars; begin ResizeScrollBars; if FScrollBars in [ssBoth, ssVertical] then sbVert.PaintTo(Canvas); if FScrollBars in [ssBoth, ssHorizontal] then sbHorz.PaintTo(Canvas); if FScrollBars = ssBoth then with Canvas do begin Brush.Color := clSilver; FillRect(Rect(sbVert.Left, sbHorz.Top + 1, sbVert.Left + sbVert.Width, sbHorz.Top + sbHorz.Height)); end; end; //-------------------------------------------------------------- // FRESH LINE BITMAP //-------------------------------------------------------------- procedure TGLSCustomMemo.FreshLineBitmap; var eRect: TRect; begin eRect := EditorRect; with FLineBitmap do begin Width := eRect.Right - eRect.Left; Height := FCellSize.H; FLineBitmap.Canvas.Font.Assign(Self.Canvas.Font); end; end; //-------------------------------------------------------------- // PAINT //-------------------------------------------------------------- procedure TGLSCustomMemo.Paint; var pTop, pBottom: TFullPos; rct, eRect: TRect; i: integer; clipRgn: HRGN; Attrs: string; begin if TGLSMemoStrings(Lines).FLockCount > 0 then Exit; with Canvas do begin if FCellSize.H = 0 then SetFont(FFont); FreshLineBitmap; Border(Canvas, Rect(0, 0, Width, Height), btLowered); DrawMargin; DrawGutter; DrawScrollBars; eRect := EditorRect; clipRgn := CreateRectRgn(eRect.Left, eRect.Top, eRect.Right, eRect.Bottom); ExtSelectClipRgn(Canvas.Handle, clipRgn, RGN_AND); DeleteObject(clipRgn); rct := Canvas.ClipRect; pTop := CharFromPos(rct.Left, rct.Top); pBottom := CharFromPos(rct.Left, rct.Bottom); if Assigned(FOnGetLineAttrs) then for i := 0 to Lines.Count - 1 do if not ValidAttrs[i] then begin FOnGetLineAttrs(Self, i, Attrs); CharAttrs[i] := Attrs; ValidAttrs[i] := True; end; for i := pTop.LineNo to pBottom.LineNo do DrawLine(i); end; end; //-------------------------------------------------------------- // GET VISIBLE //-------------------------------------------------------------- function TGLSCustomMemo.GetVisible(Index: integer): integer; var Coord: TFullPos; Cell: TCellPos; eRect: TRect; begin eRect := EditorRect; Coord := CharFromPos(eRect.Right - 1, eRect.Bottom - 1); Cell := CellFromPos(eRect.Right - 1, eRect.Bottom - 1); case Index of 0: Result := Cell.X; 1: Result := Cell.Y; 2: Result := Coord.Pos - 1; 3: Result := Coord.LineNo - 1; else Result := 0; end; end; //-------------------------------------------------------------- // IS LINE VISIBLE //-------------------------------------------------------------- function TGLSCustomMemo.IsLineVisible(LineNo: integer): Boolean; begin if FCellSize.H = 0 then SetFont(FFont); Result := (FTopLine <= LineNo) and (LineNo <= LastVisibleLine + 1); end; //-------------------------------------------------------------- // MAKE VISIBLE //-------------------------------------------------------------- procedure TGLSCustomMemo.MakeVisible; var Modified: Boolean; begin Modified := False; if CurX < FLeftCol then begin FLeftCol := CurX - 2; if FLeftCol < 0 then FLeftCol := 0; Modified := True; end; if CurX > LastVisiblePos then begin if (FScrollBars in [ssBoth, ssHorizontal]) or (ScrollMode = smAuto) then begin FLeftCol := FLeftCol + CurX - LastVisiblePos + 2; end else CurX := LastVisiblePos; Modified := True; end; if CurY < FTopLine then begin FTopLine := CurY; if FTopLine < 0 then FTopLine := 0; Modified := True; end; if CurY > LastVisibleLine then begin if (FScrollBars in [ssBoth, ssVertical]) or (ScrollMode = smAuto) then begin FTopLine := FTopLine + CurY - LastVisibleLine; end else CurY := LastVisibleLine; Modified := True; end; if Modified then Invalidate; end; //-------------------------------------------------------------- // RESIZE EDITOR //-------------------------------------------------------------- procedure TGLSCustomMemo.ResizeEditor; begin ResizeScrollBars; ResizeGutter; MakeVisible; Invalidate; end; //-------------------------------------------------------------- // FIND TEXT //-------------------------------------------------------------- function TGLSCustomMemo.FindText(Text: string; Options: TFindOptions; Select: Boolean): Boolean; var i, p: integer; s1, s0, s: string; //----------------------------------------------------------- function LastPos(const Substr, s: string): integer; var i, j, lenSub: integer; begin Result := 0; lenSub := Length(Substr); i := Length(s) - lenSub + 1; while i > 0 do begin if s[i] = Substr[1] then begin Result := i; for j := i + 1 to i + lenSub - 1 do if s[j] <> Substr[j - i + 1] then begin Result := 0; break; end; end; if Result <> 0 then break; Dec(i); end; end; //----------------------------------------------------------- begin Result := False; if not (frMatchCase in Options) then Text := AnsiLowerCase(Text); if SelLength > 0 then ClearSelection; s := Lines[CurY]; s0 := Copy(s, 1, CurX); s1 := Copy(s, CurX + 1, Length(s)); i := CurY; while True do begin if not (frMatchCase in Options) then begin s0 := AnsiLowerCase(s0); s1 := AnsiLowerCase(s1); end; if frDown in Options then p := Pos(Text, s1) else p := LastPos(Text, s0); if p > 0 then begin Result := True; CurY := i; if frDown in Options then CurX := Length(s0) + p - 1 else CurX := p - 1; if Select then begin if not (frDown in Options) then CurX := CurX + Length(Text); ClearSelection; if frDown in Options then CurX := CurX + Length(Text) else CurX := CurX - Length(Text); ExpandSelection; end; break; end; if frDown in Options then Inc(i) else Dec(i); if (i < 0) or (i > Lines.Count - 1) then break; if frDown in Options then begin s0 := ''; s1 := Lines[i]; end else begin s0 := Lines[i]; s1 := ''; end; end; end; //-------------------------------------------------------------- // RESIZE SCROLLBARS //-------------------------------------------------------------- procedure TGLSCustomMemo.ResizeScrollBars; var eRect, sbRect: TRect; MaxLen, OldMax, NewTop, Margin: integer; begin eRect := EditorRect; if FScrollBars in [ssBoth, ssVertical] then begin with sbVert do begin Width := 16; Height := eRect.Bottom - eRect.Top + 1; Left := eRect.Right; Top := eRect.Top; OldMax := MaxPosition; MaxPosition := (Lines.Count - 1) - (LastVisibleLine - FTopLine); NewTop := FTopLine; if (FTopLine > 0) and (LastVisibleLine > Lines.Count - 1) then begin Dec(NewTop, LastVisibleLine - (Lines.Count - 1)); if NewTop < 0 then NewTop := 0; MaxPosition := NewTop; end; if MaxPosition < 0 then MaxPosition := 0; Position := NewTop; Total := Lines.Count; if OldMax <> MaxPosition then begin if NewTop <> FTopLine then begin DoScroll(sbVert, NewTop - FTopLine); FGutter.Invalidate; end; sbRect := sbVert.FullRect; InvalidateRect(Handle, @sbRect, True); end; end; end; if FScrollBars in [ssBoth, ssHorizontal] then begin MaxLen := MaxLength; with sbHorz do begin Width := Self.Width - 4; if FScrollBars = ssBoth then Width := Width - sbVert.Width; Height := 16; Left := 2; Top := eRect.Bottom; OldMax := MaxPosition; Margin := LastVisiblePos - MaxLen; if Margin < 2 then Margin := 2; MaxPosition := MaxLen - (LastVisiblePos - FLeftCol) + Margin; if MaxPosition < 0 then MaxPosition := 0; Position := FLeftCol; Total := MaxLen; if OldMax <> MaxPosition then begin if MaxPosition = 0 then begin FLeftCol := 0; InvalidateRect(Handle, @eRect, True); ; FGutter.Invalidate; end; sbRect := sbHorz.FullRect; InvalidateRect(Handle, @sbRect, True); end; end; end; end; //-------------------------------------------------------------- // RESIZE GUTTER //-------------------------------------------------------------- procedure TGLSCustomMemo.ResizeGutter; var eRect: TRect; begin eRect := EditorRect; with FGutter do begin Height := eRect.Bottom - eRect.Top; end; end; //-------------------------------------------------------------- // CREATE PARAMS //-------------------------------------------------------------- procedure TGLSCustomMemo.CreateParams(var Params: TCreateParams); begin inherited; end; //-------------------------------------------------------------- // UNDO, REDO //-------------------------------------------------------------- procedure TGLSCustomMemo.Undo; begin FUndoList.Undo; end; procedure TGLSCustomMemo.Redo; begin FUndoList.Redo; end; //-------------------------------------------------------------- // SET UNDO LIMIT //-------------------------------------------------------------- procedure TGLSCustomMemo.SetUndoLimit(Value: integer); begin if (FUndoLimit <> Value) then begin if Value <= 0 then Value := 1; if Value > 100 then Value := 100; FUndoLimit := Value; FUndoList.Limit := Value; end; end; //-------------------------------------------------------------- // UNDO (REDO) CHANGE //-------------------------------------------------------------- procedure TGLSCustomMemo.UndoChange; begin if Assigned(FOnUndoChange) then FOnUndoChange(Self, FUndoList.Pos < FUndoList.Count, FUndoList.Pos > 0); end; //-------------------------------------------------------------- // CAN UNDO //-------------------------------------------------------------- function TGLSCustomMemo.CanUndo: boolean; begin Result := FUndoList.FPos < FUndoList.Count; end; //-------------------------------------------------------------- // CAN REDO //-------------------------------------------------------------- function TGLSCustomMemo.CanRedo: Boolean; begin Result := FUndoList.FPos > 0; end; //-------------------------------------------------------------- // CLEAR UNDO LIST //-------------------------------------------------------------- procedure TGLSCustomMemo.ClearUndoList; begin if Assigned(FUndoList) then FUndoList.Clear; end; //-------------------------------------------------------------- // SET SCROLL BARS //-------------------------------------------------------------- procedure TGLSCustomMemo.SetScrollBars(Value: System.UITypes.TScrollStyle); begin if FScrollBars <> Value then begin FScrollBars := Value; if not (csLoading in ComponentState) then ResizeEditor; end; end; //-------------------------------------------------------------- // CREATE //-------------------------------------------------------------- constructor TGLSCustomMemo.Create(AOwner: TComponent); begin inherited; ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks, csReplicatable]; Width := 100; Height := 40; TabStop := True; Cursor := crIBeam; FFont := TFont.Create; FFont.Name := 'Courier New'; FFont.Size := 10; Canvas.Font.Assign(FFont); FHiddenCaret := False; FCaretVisible := False; FCurX := 0; FCurY := 0; FLeftCol := 0; FTopLine := 0; FTabSize := 4; FMargin := 2; FAutoIndent := True; FLines := TGLSMemoStrings.Create; TGLSMemoStrings(FLines).FMemo := Self; FScrollBars := ssBoth; FScrollBarWidth := 16; sbVert := TGLSMemoScrollBar.Create(Self, sbVertical); sbVert.Width := FScrollBarWidth; sbHorz := TGLSMemoScrollBar.Create(Self, sbHorizontal); sbHorz.Height := FScrollBarWidth; FGutter := TGLSMemoGutter.Create; with FGutter do begin FLeft := 2; FTop := 2; FWidth := 0; FHeight := 0; FColor := clBtnFace; FMemo := Self; end; FSelStartX := 0; FSelStartY := 0; FSelEndX := 0; FSelEndY := 0; FBkColor := clWhite; FSelColor := clWhite; FSelBkColor := clNavy; FStyles := TStyleList.Create; FStyles.Add(clBlack, clWhite, []); FSelCharPos.LineNo := -1; FSelCharPos.Pos := -1; FSelCharStyle := -1; FLineBitmap := TBitmap.Create; FLeftButtonDown := False; FScrollMode := smAuto; FUndoList := TGLSMemoUndoList.Create; FFirstUndoList := FUndoList; FUndoList.Memo := Self; FUndoLimit := 100; TGLSMemoStrings(FLines).DoAdd(''); FAfterDoubleClick := False; end; //-------------------------------------------------------------- // DESTROY //-------------------------------------------------------------- destructor TGLSCustomMemo.Destroy; begin FFont.Free; FLines.Free; FGutter.Free; sbVert.Free; sbHorz.Free; FStyles.Free; FLineBitmap.Free; FFirstUndoList.Free; inherited; end; // ---------------------TGLSMemoScrollBar functions procedure TGLSMemoScrollBar.SetParams(Index: integer; Value: integer); begin case Index of 0: if Left <> Value then FLeft := Value; 1: if Top <> Value then FTop := Value; 2: if Width <> Value then FWidth := Value; 3: if Height <> Value then FHeight := Value; 4: if Total <> Value then FTotal := Value; 5: if MaxPosition <> Value then FMaxPosition := Value; 6: if Position <> Value then FPosition := Value; end; end; //-------------------- CREATE ------------------------------ constructor TGLSMemoScrollBar.Create(AParent: TGLSMemoAbstractScrollableObject; AKind: TScrollBarKind); begin FParent := AParent; FButtonLength := 16; FKind := AKind; FState := sbsWait; end; //-------------------- RECT ----------------------- function TGLSMemoScrollBar.GetRect: TRect; begin Result := Rect(Left, Top, Left + Width, Top + Height); end; //-------------------- GET THUMB RECT ----------------------- function TGLSMemoScrollBar.GetThumbRect: TRect; var TotalLen, FreeLen, ThumbLen, ThumbOffset, ThumbCoord: integer; K: double; begin if MaxPosition <= 0 then begin Result := Rect(0, 0, 0, 0); Exit; end; if Kind = sbVertical then TotalLen := Height else TotalLen := Width; FreeLen := TotalLen - 2 * FButtonLength; K := (Total - MaxPosition) / MaxPosition; if K > 0 then begin ThumbLen := round(FreeLen * K / (1 + K)); if ThumbLen < 8 then ThumbLen := 8; end else ThumbLen := 8; if ThumbLen >= FreeLen then Result := Rect(0, 0, 0, 0) else begin ThumbOffset := round((FreeLen - ThumbLen) * Position / MaxPosition); ThumbCoord := FButtonLength + ThumbOffset; if Kind = sbVertical then Result := Rect(Left + 1, Top + ThumbCoord, Left + Width, Top + ThumbCoord + ThumbLen) else Result := Rect(Left + ThumbCoord, Top + 1, Left + ThumbCoord + ThumbLen, Top + Height); end; end; //-------------------- GET Back RECT ----------------------- function TGLSMemoScrollBar.GetBackRect: TRect; begin if Kind = sbVertical then Result := Rect(Left + 1, Top, Left + Width, Top + FButtonLength) else Result := Rect(Left, Top + 1, Left + FButtonLength, Top + Height); end; //-------------------- GET MIDDLE RECT ----------------------- function TGLSMemoScrollBar.GetMiddleRect: TRect; var bRect, fRect: TRect; begin bRect := BackRect; fRect := ForwardRect; if Kind = sbVertical then Result := Rect(Left + 1, bRect.Bottom, Left + Width, fRect.Top) else Result := Rect(bRect.Right, Top + 1, fRect.Left, Top + Height); end; //-------------------- GET Forward RECT ----------------------- function TGLSMemoScrollBar.GetForwardRect: TRect; begin if Kind = sbVertical then Result := Rect(Left + 1, Top + Height - FButtonLength, Left + Width, Top + Height) else Result := Rect(Left + Width - FButtonLength, Top + 1, Left + Width, Top + Height); end; //-------------------- GET PAGE BACK RECT ----------------------- function TGLSMemoScrollBar.GetPgBackRect: TRect; var thRect: TRect; begin thRect := GetThumbRect; if thRect.Bottom = 0 then begin Result := Rect(0, 0, 0, 0); Exit; end; if Kind = sbVertical then Result := Rect(Left + 1, Top + FButtonLength, Left + Width, thRect.Top - 1) else Result := Rect(Left + FButtonLength, Top + 1, thRect.Left - 1, Top + Height); end; //-------------------- GET PG FORWARD RECT ----------------------- function TGLSMemoScrollBar.GetPgForwardRect: TRect; var thRect: TRect; begin thRect := GetThumbRect; if thRect.Bottom = 0 then begin Result := Rect(0, 0, 0, 0); Exit; end; if Kind = sbVertical then Result := Rect(Left + 1, thRect.Bottom, Left + Width, Top + Height - FButtonLength) else Result := Rect(thRect.Right, Top + 1, Left + Width - FButtonLength, Top + Height); end; //-------------------- PAINT TO ----------------------- procedure TGLSMemoScrollBar.PaintTo(ACanvas: TCanvas); var sRect, mRect, gRect, thRect: TRect; iconX, iconY, shift: integer; begin with ACanvas do begin if Kind = sbVertical then begin Pen.Color := clSilver; MoveTo(Left, Top); LineTo(Left, Top + Height); sRect := BackRect; Brush.Color := clSilver; FillRect(sRect); if State = sbsBack then begin shift := 1; Pen.Color := clGray; with sRect do Rectangle(Left, Top, Right, Bottom); end else begin shift := 0; Border(ACanvas, sRect, btFlatRaised); end; iconX := sRect.Left + (Width - 1 - 7) div 2; iconY := sRect.Top + (FButtonLength - 8) div 2; Draw(iconX + shift, iconY + shift, bmScrollBarUp); gRect := ForwardRect; Brush.Color := clSilver; FillRect(gRect); if State = sbsForward then begin shift := 1; Pen.Color := clGray; with gRect do Rectangle(Left, Top, Right, Bottom); end else begin shift := 0; Border(ACanvas, gRect, btFlatRaised); end; iconX := gRect.Left + (Width - 1 - 7) div 2; iconY := gRect.Top + (FButtonLength - 8) div 2; Draw(iconX + shift, iconY + shift, bmScrollBarDown); mRect := Rect(sRect.Left, sRect.Bottom, gRect.Right, gRect.Top); end else begin Pen.Color := clSilver; MoveTo(Left, Top); LineTo(Left + Width, Top); sRect := BackRect; Brush.Color := clSilver; FillRect(sRect); if State = sbsBack then begin shift := 1; Pen.Color := clGray; with sRect do Rectangle(Left, Top, Right, Bottom); end else begin shift := 0; Border(ACanvas, sRect, btFlatRaised); end; iconX := sRect.Left + shift + (FButtonLength - 8) div 2; iconY := sRect.Top + shift + (Height - 1 - 7) div 2; Draw(iconX + shift, iconY + shift, bmScrollBarLeft); gRect := ForwardRect; Brush.Color := clSilver; FillRect(gRect); if State = sbsForward then begin shift := 1; Pen.Color := clGray; with gRect do Rectangle(Left, Top, Right, Bottom); end else begin shift := 0; Border(ACanvas, gRect, btFlatRaised); end; iconX := gRect.Left + (FButtonLength - 8) div 2; iconY := gRect.Top + (Height - 1 - 7) div 2; Draw(iconX + shift, iconY + shift, bmScrollBarRight); mRect := Rect(sRect.Right, sRect.Top, gRect.Left, gRect.Bottom); end; Brush.Bitmap := bmScrollBarFill; FillRect(mRect); Brush.Bitmap := nil; if State = sbsPageBack then begin Brush.Color := clGray; FillRect(PageBackRect); end; if State = sbsPageForward then begin Brush.Color := clGray; FillRect(PageForwardRect); end; thRect := ThumbRect; Brush.Color := clSilver; FillRect(thRect); Border(ACanvas, thRect, btFlatRaised); end; end; //-------------------- SET STATE ---------- procedure TGLSMemoScrollBar.SetState(Value: TsbState); begin if FState <> Value then begin FState := Value; end; end; //-------------------- MOUSE DOWN ------------ function TGLSMemoScrollBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; var sRect, gRect, thRect, pbRect, pfRect: TRect; begin Result := False; if (Width = 0) or (Height = 0) then Exit; sRect := BackRect; gRect := ForwardRect; pbRect := PageBackRect; pfRect := PageForwardRect; thRect := ThumbRect; if PointInRect(Point(X, Y), sRect) then begin State := sbsBack; InvalidateRect(Parent.Handle, @sRect, True); Result := True; Exit; end; if PointInRect(Point(X, Y), gRect) then begin State := sbsForward; InvalidateRect(Parent.Handle, @gRect, True); Result := True; Exit; end; if PointInRect(Point(X, Y), pbRect) then begin State := sbsPageBack; InvalidateRect(Parent.Handle, @pbRect, True); Result := True; Exit; end; if PointInRect(Point(X, Y), pfRect) then begin State := sbsPageForward; InvalidateRect(Parent.Handle, @pfRect, True); Result := True; Exit; end; if PointInRect(Point(X, Y), thRect) then begin State := sbsDragging; FXOffset := X - thRect.Left; FYOffset := Y - thRect.Top; Result := True; Exit; end; end; //-------------------- MOUSE UP ---------- function TGLSMemoScrollBar.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; var sRect, gRect, thRect, pbRect, pfRect: TRect; begin Result := False; if (Width = 0) or (Height = 0) then Exit; sRect := BackRect; gRect := ForwardRect; pbRect := PageBackRect; pfRect := PageForwardRect; thRect := ThumbRect; case State of sbsBack: begin State := sbsWait; InvalidateRect(Parent.Handle, @sRect, True); FParent.DoScroll(Self, -1); Result := True; Exit; end; sbsForward: begin State := sbsWait; InvalidateRect(Parent.Handle, @gRect, True); FParent.DoScroll(Self, 1); Result := True; Exit; end; sbsPageBack: begin State := sbsWait; InvalidateRect(Parent.Handle, @pbRect, True); FParent.DoScrollPage(Self, -1); Result := True; Exit; end; sbsPageForward: begin State := sbsWait; InvalidateRect(Parent.Handle, @pfRect, True); FParent.DoScrollPage(Self, 1); Result := True; Exit; end; sbsDragging: begin State := sbsWait; Result := True; Exit; end; end; end; //-------------------- MOUSE MOVE ----------- function TGLSMemoScrollBar.MouseMove(Shift: TShiftState; X, Y: Integer): Boolean; var sRect, gRect, thRect, pbRect, pfRect: TRect; begin Result := False; if (Width = 0) or (Height = 0) then Exit; sRect := BackRect; gRect := ForwardRect; pbRect := PageBackRect; pfRect := PageForwardRect; thRect := ThumbRect; case State of sbsBack: if not PointInRect(Point(X, Y), sRect) then begin State := sbsWait; InvalidateRect(Parent.Handle, @sRect, True); Result := True; Exit; end; sbsForward: if not PointInRect(Point(X, Y), gRect) then begin State := sbsWait; InvalidateRect(Parent.Handle, @gRect, True); Result := True; Exit; end; sbsPageBack: if not PointInRect(Point(X, Y), pbRect) then begin State := sbsWait; InvalidateRect(Parent.Handle, @pbRect, True); Result := True; Exit; end; sbsPageForward: if not PointInRect(Point(X, Y), pfRect) then begin State := sbsWait; InvalidateRect(Parent.Handle, @pfRect, True); Result := True; Exit; end; sbsDragging: begin MoveThumbTo(X, Y); Result := True; Exit; end; end; end; //-------------------- MOVE THUMB TO ------------ function TGLSMemoScrollBar.MoveThumbTo(X, Y: Integer): integer; var thRect, mRect: TRect; FreeLen, ThumbLen, NewPosition, NewOffset: integer; begin thRect := ThumbRect; mRect := MiddleRect; NewOffset := 0; FreeLen := 0; ThumbLen := 0; case Kind of sbVertical: begin FreeLen := mRect.Bottom - mRect.Top; ThumbLen := thRect.Bottom - thRect.Top; NewOffset := Y - FYOffset - (Top + FButtonLength); end; sbHorizontal: begin FreeLen := mRect.Right - mRect.Left; ThumbLen := thRect.Right - thRect.Left; NewOffset := X - FXOffset - (Left + FButtonLength); end end; NewPosition := round(NewOffset * MaxPosition / (FreeLen - ThumbLen)); Result := NewPosition - Position; if NewPosition <> Position then begin Parent.DoScroll(Self, NewPosition - Position); end; end; //-------------------------------------------------------------- // GUTTER //-------------------------------------------------------------- //-------------------- SET PARAMS ----------------------- procedure TGLSMemoGutter.SetParams(Index: integer; Value: integer); begin case Index of 0: FLeft := Value; 1: FTop := Value; 2: FWidth := Value; 3: FHeight := Value; end; end; //-------------------- PAINT TO ----------------------- procedure TGLSMemoGutter.PaintTo(ACanvas: TCanvas); var LineNo, T, H: integer; begin with ACanvas do begin Pen.Color := clGray; MoveTo(Left + Width - 1, Top); LineTo(Left + Width - 1, Top + Height); Pen.Color := clWhite; MoveTo(Left + Width - 2, Top); LineTo(Left + Width - 2, Top + Height); Brush.Color := Self.FColor; FillRect(Rect(Left, Top, Left + Width - 2, Top + Height)); if Assigned(FMemo.OnGutterDraw) then begin T := Top; H := FMemo.FCellSize.H; LineNo := FMemo.FTopLine; while T < Top + Height do begin FMemo.OnGutterDraw(FMemo, ACanvas, LineNo, Rect(Left, T, Left + Width - 2, T + H)); T := T + H; Inc(LineNo); if LineNo >= FMemo.Lines.Count then break; end; end; end; end; //-------------------- INVALIDATE ----------------------- procedure TGLSMemoGutter.Invalidate; var gRect: TRect; begin gRect := Rect(Left, Top, Left + Width, Top + Height); InvalidateRect(FMemo.Handle, @gRect, True); end; //-------------------- GET RECT ----------------------- function TGLSMemoGutter.GetRect: TRect; begin Result := Rect(Left, Top, Left + Width, Top + Height); end; // ---------------------TStyleList procedure TStyleList.CheckRange(Index: integer); begin if (Index < 0) or (Index >= Count) then raise EListError.Create('Incorrect list item index ' + IntToStr(Index)); end; //-------------------- DESTROY --------------------------- destructor TStyleList.Destroy; begin Clear; inherited; end; //-------------------- CHANGE --------------------------- procedure TStyleList.Change(Index: integer; ATextColor, ABkCOlor: TColor; AStyle: TFontStyles); var P: TCharStyle; begin CheckRange(Index); P := TCharStyle(Items[Index]); P.TextColor := ATextColor; P.BkColor := ABkColor; P.Style := AStyle; end; //-------------------- ADD --------------------------- function TStyleList.Add(ATextColor, ABkColor: TColor; AStyle: TFontStyles): Integer; var P: TCharStyle; begin P := TCharStyle.Create; with P do begin TextColor := ATextColor; BkColor := ABkColor; Style := AStyle; end; Result := inherited Add(P); end; //-------------------- CLEAR --------------------------- procedure TStyleList.Clear; begin while Count > 0 do Delete(0); end; //-------------------- DELETE --------------------------- procedure TStyleList.Delete(Index: Integer); var P: TCharStyle; begin CheckRange(Index); P := TCharStyle(Items[Index]); P.Free; inherited; end; //-------------------- GET/SET TEXT COLOR --------------------------- function TStyleList.GetTextColor(Index: Integer): TColor; begin CheckRange(Index); Result := TCharStyle(Items[Index]).TextColor; end; procedure TStyleList.SetTextColor(Index: Integer; Value: TColor); begin CheckRange(Index); TCharStyle(Items[Index]).TextColor := Value; end; //-------------------- GET/SET BK COLOR --------------------------- function TStyleList.GetBkColor(Index: Integer): TColor; begin CheckRange(Index); Result := TCharStyle(Items[Index]).BkColor; end; procedure TStyleList.SetBkColor(Index: Integer; Value: TColor); begin CheckRange(Index); TCharStyle(Items[Index]).BkColor := Value; end; //-------------------- GET/SET STYLE --------------------------- function TStyleList.GetStyle(Index: Integer): TFontStyles; begin CheckRange(Index); Result := TCharStyle(Items[Index]).Style; end; procedure TStyleList.SetStyle(Index: Integer; Value: TFontStyles); begin CheckRange(Index); TCharStyle(Items[Index]).Style := Value; end; // ---------------------TGLSMemoStrings destructor TGLSMemoStrings.Destroy; var P: TObject; begin while Count > 0 do begin P := inherited GetObject(0); P.Free; inherited Delete(0); end; inherited; end; //-------------------- CLEAR ---------------------- procedure TGLSMemoStrings.Clear; begin while Count > 0 do begin Delete(0); if (Count = 1) and (Strings[0] = '') then break; end; end; //-------------------- ASSIGN ---------------------- procedure TGLSMemoStrings.Assign(Source: TPersistent); var P: TObject; begin if Source is TStrings then begin BeginUpdate; try while Count > 0 do begin P := inherited GetObject(0); P.Free; inherited Delete(0); end; // inherited Clear; AddStrings(TStrings(Source)); finally EndUpdate; end; Exit; end; inherited Assign(Source); end; //-------------------- ADD ---------------------- function TGLSMemoStrings.DoAdd(const S: string): Integer; begin Result := inherited AddObject(S, nil); end; //-------------------- ADD ---------------------- function TGLSMemoStrings.Add(const S: string): Integer; begin if Assigned(FMemo.Parent) then Result := FMemo.AddString(S) else Result := DoAdd(S); end; //-------------------- OBJECT ---------------------- function TGLSMemoStrings.AddObject(const S: string; AObject: TObject): Integer; begin if AObject <> nil then raise EInvalidOp.Create(SObjectsNotSupported); Result := DoAdd(S); end; //-------------------- INSERT ---------------------- procedure TGLSMemoStrings.InsertObject(Index: Integer; const S: string; AObject: TObject); begin if AObject <> nil then raise EInvalidOp.Create(SObjectsNotSupported); DoInsert(Index, S); end; //-------------------- DO INSERT ---------------------- procedure TGLSMemoStrings.DoInsert(Index: Integer; const S: string); begin InsertItem(Index, S, nil); end; //-------------------- INSERT ---------------------- procedure TGLSMemoStrings.Insert(Index: Integer; const S: string); begin if Assigned(FMemo) then FMemo.InsertString(Index, S) else DoInsert(Index, S); end; //-------------------- DELETE ---------------------- procedure TGLSMemoStrings.Delete(Index: Integer); var P: TObject; begin if (Index < 0) or (Index > Count - 1) then Exit; if FDeleting or (not Assigned(FMemo)) then begin P := inherited GetObject(Index); P.Free; inherited; end else begin FMemo.DeleteLine(Index, -1, -1, -1, -1, True); end; end; //-------------------- LOAD FROM FILE ---------------------- procedure TGLSMemoStrings.LoadFromFile(const FileName: string); begin with FMemo do begin ClearSelection; ClearUndoList; CurX := 0; CurY := 0; end; Clear; inherited; FMemo.Invalidate; end; //-------------------- SET UPDATE STATE ---------------------- procedure TGLSMemoStrings.SetUpdateState(Updating: Boolean); begin if Updating then Inc(FLockCount) else if FLockCount > 0 then Dec(FLockCount); end; //-------------------- CHECK RANGE --------------------------- procedure TGLSMemoStrings.CheckRange(Index: integer); begin if (Index < 0) or (Index >= Count) then raise EListError('Incorrect index of list item ' + IntToStr(Index)); end; //-------------------- GET OBJECT --------------------------- function TGLSMemoStrings.GetObject(Index: Integer): TObject; begin CheckRange(Index); Result := inherited GetObject(Index); if Assigned(Result) and (Result is TLineProp) then Result := TLineProp(Result).FObject; end; //-------------------- PUT OBJECT --------------------------- procedure TGLSMemoStrings.PutObject(Index: Integer; AObject: TObject); var P: TObject; begin CheckRange(Index); P := Objects[Index]; if Assigned(P) and (P is TLineProp) then TLineProp(P).FObject := AObject else inherited PutObject(Index, AObject); end; //-------------------- GET LINE PROP --------------------------- function TGLSMemoStrings.GetLineProp(Index: integer): TLineProp; var P: TObject; begin CheckRange(Index); Result := nil; P := inherited GetObject(Index); if Assigned(P) and (P is TLineProp) then Result := TLineProp(P); end; //-------------------- CREATE PROP -------------------------- function TGLSMemoStrings.CreateProp(Index: integer): TLineProp; begin Result := TLineProp.Create; with Result do begin FStyleNo := 0; FInComment := False; FInBrackets := -1; FValidAttrs := False; FCharAttrs := ''; FObject := Objects[Index]; end; inherited PutObject(Index, Result); end; //-------------------- GET LINE STYLE -------------------------- function TGLSMemoStrings.GetLineStyle(Index: integer): integer; var P: TLineProp; begin P := LineProp[Index]; if P = nil then Result := 0 else Result := P.FStyleNo; end; //-------------------- SET LINE STYLE -------------------------- procedure TGLSMemoStrings.SetLineStyle(Index: integer; Value: integer); var P: TLineProp; begin P := LineProp[Index]; if P = nil then P := CreateProp(Index); P.FStyleNo := Value; end; //-------------------- GET/SET IN COMMENT --------------------------- function TGLSMemoStrings.GetInComment(Index: Integer): Boolean; var P: TLineProp; begin P := LineProp[Index]; if P = nil then Result := False else Result := P.FInComment; end; procedure TGLSMemoStrings.SetInComment(Index: Integer; Value: Boolean); var P: TLineProp; begin P := LineProp[Index]; if P = nil then P := CreateProp(Index); P.FInComment := Value; end; //-------------------- GET/SET IN BRACKETS --------------------------- function TGLSMemoStrings.GetInBrackets(Index: Integer): integer; var P: TLineProp; begin P := LineProp[Index]; if P = nil then Result := -1 else Result := P.FInBrackets; end; procedure TGLSMemoStrings.SetInBrackets(Index: Integer; Value: integer); var P: TLineProp; begin P := LineProp[Index]; if P = nil then P := CreateProp(Index); P.FInBrackets := Value; end; //-------------------- GET/SET VALID ATTRS --------------------------- function TGLSMemoStrings.GetValidAttrs(Index: Integer): Boolean; var P: TLineProp; begin P := LineProp[Index]; if P = nil then Result := False else Result := P.FValidAttrs; end; procedure TGLSMemoStrings.SetValidAttrs(Index: Integer; Value: Boolean); var P: TLineProp; begin P := LineProp[Index]; if P = nil then P := CreateProp(Index); P.FValidAttrs := Value; end; //-------------------- GET/SET CHAR ATTRS --------------------------- function TGLSMemoStrings.GetCharAttrs(Index: Integer): string; var P: TLineProp; begin P := LineProp[Index]; if P = nil then Result := '' else Result := P.FCharAttrs; end; procedure TGLSMemoStrings.SetCharAttrs(Index: Integer; const Value: string); var P: TLineProp; begin P := LineProp[Index]; if P = nil then P := CreateProp(Index); P.FCharAttrs := Value; end; // ---------------------TGLSMemoUndo constructor TGLSMemoUndo.Create(ACurX0, ACurY0, ACurX, ACurY: integer; const AText: string); begin inherited Create; FUndoCurX0 := ACurX0; FUndoCurY0 := ACurY0; FUndoCurX := ACurX; FUndoCurY := ACurY; FUndoText := AText; end; procedure TGLSMemoUndo.Undo; begin if Assigned(FMemo) then with FMemo do begin CurY := FUndoCurY; CurX := FUndoCurX; PerformUndo; CurY := FUndoCurY0; CurX := FUndoCurX0; end; end; procedure TGLSMemoUndo.Redo; begin if Assigned(FMemo) then with FMemo do begin CurY := FUndoCurY0; CurX := FUndoCurX0; PerformRedo; CurY := FUndoCurY; CurX := FUndoCurX; end; end; function TGLSMemoUndo.Append(NewUndo: TGLSMemoUndo): Boolean; begin Result := False; end; //---------------- TINSERT CHAR UNDO -------------------------- procedure TGLSMemoInsCharUndo.PerformUndo; var i: integer; CurrLine: string; begin for i := Length(FUndoText) downto 1 do begin CurrLine := FMemo.Lines[FMemo.CurY]; if ((FUndoText[i] = #13) and (FMemo.CurX = 0)) or (FUndoText[i] = CurrLine[FMemo.CurX]) then FMemo.BackSpace; end; end; procedure TGLSMemoInsCharUndo.PerformRedo; var i: integer; begin with FMemo do for i := 1 to Length(FUndoText) do if FUndoText[i] = #13 then NewLine else InsertChar(FUndoText[i]); end; function TGLSMemoInsCharUndo.Append(NewUndo: TGLSMemoUndo): Boolean; begin Result := False; if not ((NewUndo is TGLSMemoInsCharUndo) and (NewUndo.UndoCurX0 = FUndoCurX) and (NewUndo.UndoCurY0 = FUndoCurY)) then Exit; FUndoText := FUndoText + NewUndo.FUndoText; FUndoCurX := NewUndo.UndoCurX; FUndoCurY := NewUndo.UndoCurY; Result := True; end; //---------------- TDELETE CHAR UNDO -------------------------- procedure TGLSMemoDelCharUndo.PerformUndo; var i: integer; begin with FMemo do for i := 1 to Length(FUndoText) do begin if not FIsBackspace then begin CurY := FUndoCurY0; CurX := FUndoCurX0; end; if FUndoText[i] = #13 then NewLine else InsertChar(FUndoText[i]); end; end; procedure TGLSMemoDelCharUndo.PerformRedo; var i: integer; begin with FMemo do for i := 1 to Length(FUndoText) do if FIsBackspace then BackSpace else DeleteChar(-1, -1); end; function TGLSMemoDelCharUndo.Append(NewUndo: TGLSMemoUndo): Boolean; begin Result := False; if not ((NewUndo is TGLSMemoDelCharUndo) and (NewUndo.UndoCurX0 = FUndoCurX) and (NewUndo.UndoCurY0 = FUndoCurY)) then Exit; if TGLSMemoDelCharUndo(NewUndo).FIsBackspace <> FIsBackspace then Exit; FUndoText := NewUndo.FUndoText + FUndoText; FUndoCurX := NewUndo.UndoCurX; FUndoCurY := NewUndo.UndoCurY; Result := True; end; //---------------- TDELETE BUF, LINE UNDO -------------------------- constructor TGLSMemoDelLineUndo.Create(AIndex, ACurX0, ACurY0, ACurX, ACurY: integer; const AText: string); begin inherited Create(ACurX0, ACurY0, ACurX, ACurY, AText); FIndex := AIndex; end; procedure TGLSMemoDelLineUndo.PerformUndo; var SaveCurX: integer; begin with FMemo do begin SaveCurX := CurX; CurX := 0; ClearSelection; SetSelText(PChar(FUndoText + #13#10)); CurX := SaveCurX; end; end; procedure TGLSMemoDelLineUndo.PerformRedo; begin FMemo.DeleteLine(FIndex, FUndoCurX0, FUndoCurY0, FUndoCurX, FUndoCurY, True); end; procedure TGLSMemoDeleteBufUndo.PerformUndo; begin with FMemo do begin ClearSelection; SetSelText(PChar(FUndoText)); end; end; procedure TGLSMemoDeleteBufUndo.PerformRedo; begin with FMemo do begin FSelStartX := FUndoSelStartX; FSelStartY := FUndoSelStartY; FSelEndX := FUndoSelEndX; FSelEndY := FUndoSelEndY; DeleteSelection(True); end; end; //---------------- TPASTE UNDO -------------------------- procedure TGLSMemoPasteUndo.PerformUndo; begin with FMemo do begin FSelStartX := FUndoCurX0; FSelStartY := FUndoCurY0; FSelEndX := FUndoCurX; FSelEndY := FUndoCurY; DeleteSelection(True); end; end; procedure TGLSMemoPasteUndo.PerformRedo; begin with FMemo do begin ClearSelection; SetSelText(PChar(FUndoText)); end; end; //---------------- TUNDO LIST -------------------------- constructor TGLSMemoUndoList.Create; begin inherited; FPos := 0; FIsPerforming := False; FLimit := 100; end; destructor TGLSMemoUndoList.Destroy; begin Clear; inherited; end; function TGLSMemoUndoList.Get(Index: Integer): TGLSMemoUndo; begin Result := TGLSMemoUndo(inherited Get(Index)); end; function TGLSMemoUndoList.Add(Item: Pointer): Integer; begin Result := -1; if FIsPerforming then begin TGLSMemoUndo(Item).Free; Exit; end; if (Count > 0) and Items[0].Append(TGLSMemoUndo(Item)) then begin TGLSMemoUndo(Item).Free; Exit; end; TGLSMemoUndo(Item).FMemo := Self.FMemo; if FPos > 0 then while FPos > 0 do begin Delete(0); Dec(FPos); end; Insert(0, Item); if Count > FLimit then Delete(Count - 1); Memo.UndoChange; Result := 0; end; procedure TGLSMemoUndoList.Clear; begin while Count > 0 do Delete(0); FPos := 0; with Memo do if not (csDestroying in ComponentState) then UndoChange; end; procedure TGLSMemoUndoList.Delete(Index: Integer); begin TGLSMemoUndo(Items[Index]).Free; inherited; end; procedure TGLSMemoUndoList.Undo; var OldAutoIndent: Boolean; begin if FPos < Count then begin OldAutoIndent := Memo.AutoIndent; Memo.AutoIndent := False; FIsPerforming := True; Items[FPos].Undo; Inc(FPos); FIsPerforming := False; Memo.AutoIndent := OldAutoIndent; Memo.UndoChange; end; end; procedure TGLSMemoUndoList.Redo; var OldAutoIndent: Boolean; begin if FPos > 0 then begin OldAutoIndent := Memo.AutoIndent; Memo.AutoIndent := False; FIsPerforming := True; Dec(FPos); Items[FPos].Redo; FIsPerforming := False; Memo.AutoIndent := OldAutoIndent; Memo.UndoChange; end; end; procedure TGLSMemoUndoList.SetLimit(Value: integer); begin if FLimit <> Value then begin if Value <= 0 then Value := 10; if Value > 0 then Value := 100; FLimit := Value; Clear; end; end; procedure TGLSSynHiMemo.Paint; begin FIsPainting := True; try DelimiterStyle := FDelimiterStyle; CommentStyle := FCommentStyle; NumberStyle := FNumberStyle; inherited; finally FIsPainting := False; end; end; // ---------------------TGLSSynHiMemo procedure TGLSSynHiMemo.SetStyle(Index: integer; Value: TCharStyle); var No: integer; eRect: TRect; begin No := -1; case Index of 0: No := FDelimiterStyleNo; 1: No := FCommentStyleNo; 2: No := FNumberStyleNo; end; with Value do Styles.Change(No, TextColor, BkColor, Style); if not FIsPainting then begin eRect := EditorRect; InvalidateRect(Handle, @eRect, True); end; end; //-------------------------------------------------------------- // SYNTAX MEMO - SET WORD LIST //-------------------------------------------------------------- procedure TGLSSynHiMemo.SetWordList(Value: TGLSMemoStringList); begin FWordList.Assign(Value); end; procedure TGLSSynHiMemo.SetSpecialList(Value: TGLSMemoStringList); begin FSpecialList.Assign(Value); end; procedure TGLSSynHiMemo.SetBracketList(Value: TGLSMemoStringList); begin FBracketList.Assign(Value); end; //-------------------------------------------------------------- // SYNTAX MEMO - SET CASE SENSITIVE //-------------------------------------------------------------- procedure TGLSSynHiMemo.SetCaseSensitive(Value: Boolean); var LineNo: integer; begin if Value <> FCaseSensitive then begin FCaseSensitive := Value; for LineNo := 0 to Lines.Count - 1 do ValidAttrs[LineNo] := False; Invalidate; end; end; //-------------------------------------------------------------- // SYNTAX MEMO - GET TOKEN //-------------------------------------------------------------- function TGLSSynHiMemo.GetToken(const S: string; var From: integer; out TokenType: TTokenType; out StyleNo: integer): string; var i, toStart, toEnd, Len, LenSpec: integer; Done: Boolean; Brackets: string; IntPart: integer; WasPoint: Boolean; //------------------------------------------------------------- function StartsFrom(const S: string; Pos: integer; const S0: string): Boolean; begin Result := (StrLComp(PChar(S) + Pos - 1, PChar(S0), Length(S0)) = 0); end; //------------------------------------------------------------- function Equal(const s1, s2: string): Boolean; begin if FCaseSensitive then Result := s1 = s2 else Result := AnsiLowerCase(s1) = AnsiLowerCase(s2); end; begin toStart := From; toEnd := From; TokenType := ttOther; StyleNo := 0; Len := Length(S); // End of line if From > Len then begin From := -1; Result := ''; TokenType := ttEOL; StyleNo := 0; Exit; end; // Begin of multiline comment if (MultiCommentLeft <> '') and (MultiCommentRight <> '') and StartsFrom(S, From, MultiCommentLeft) then begin Result := MultiCommentLeft; FInComment := True; TokenType := ttComment; StyleNo := FCommentStyleNo; Inc(From, Length(MultiCommentLeft)); Exit; end; // Inside multiline comment if FInComment then begin toEnd := toStart; while (toEnd <= Len) and (not StartsFrom(S, toEnd, MultiCommentRight)) do Inc(toEnd); if toEnd > Len then begin Result := Copy(S, From, toEnd - From); From := toEnd; end else begin FInComment := False; toEnd := toEnd + Length(MultiCommentRight); Result := Copy(S, From, toEnd - From); From := toEnd; end; TokenType := ttComment; StyleNo := FCommentStyleNo; Exit; end; // Inside brikets if FInBrackets >= 0 then begin Brackets := FBracketList[FInBrackets]; toEnd := toStart + 1; while (toEnd <= Len) and (S[toEnd] <> Brackets[2]) do Inc(toEnd); StyleNo := integer(FBracketList.Objects[FInBrackets]); if toEnd <= Len then begin FInBrackets := -1; From := toEnd + 1; end else From := toEnd; Result := Copy(S, toStart, toEnd - toStart + 1); TokenType := ttBracket; Exit; end; // Spaces while (toStart <= Len) and (S[toStart] = ' ') do Inc(toStart); if toStart > From then begin Result := Copy(S, From, toStart - From); From := toStart; TokenType := ttSpace; StyleNo := 0; Exit; end; // Comment if (FLineComment <> '') and StartsFrom(S, From, FLineComment) then begin Result := Copy(S, From, Len); From := Len + 1; TokenType := ttComment; StyleNo := FCommentStyleNo; Exit; end; // Special keyword Done := False; for i := 0 to FSpecialList.Count - 1 do begin LenSpec := Length(FSpecialList[i]); if StrLComp(PChar(S) + toStart - 1, PChar(FSpecialList[i]), LenSpec) = 0 then begin toEnd := toStart + LenSpec - 1; StyleNo := integer(FSpecialList.Objects[i]); TokenType := ttSpecial; From := toEnd + 1; Done := True; break; end; end; // Brickets if not Done then begin for i := 0 to FBracketList.Count - 1 do begin Brackets := FBracketList[i]; if S[toStart] = Brackets[1] then begin FInBrackets := i; toEnd := toStart + 1; while (toEnd <= Len) and (S[toEnd] <> Brackets[2]) do Inc(toEnd); if toEnd <= Len then FInBrackets := -1 else Dec(toEnd); StyleNo := integer(FBracketList.Objects[i]); TokenType := ttBracket; Done := True; break; end; end; end; // Delimeters if not Done and CharInSet(S[toStart], Delimiters) then begin toEnd := toStart; StyleNo := FDelimiterStyleNo; TokenType := ttDelimiter; Done := True; end; // --- Integer or float type if not Done and CharInSet(S[toStart], ['0'..'9', '.']) then begin IntPart := 0; WasPoint := False; toEnd := toStart; Done := True; TokenType := ttInteger; StyleNo := FNumberStyleNo; while (toEnd <= Len) and CharInSet(S[toEnd], ['0'..'9', '.']) do begin if S[toEnd] = '.' then begin if not WasPoint then begin WasPoint := True; TokenType := ttFloat; end else begin TokenType := ttWrongNumber; Color := clRed; end; end else if not WasPoint then try IntPart := IntPart * 10 + Ord(S[toEnd]) - Ord('0'); except IntPart := MaxInt; end; Inc(toEnd); end; Dec(toEnd); end; // Select word if not Done then begin toEnd := toStart; while (toEnd <= Len) and not CharInSet(S[toEnd], Delimiters) do Inc(toEnd); Dec(toEnd); end; // Find in dictionary Result := Copy(S, toStart, toEnd - toStart + 1); for i := 0 to FWordList.Count - 1 do if Equal(Result, FWordList[i]) then begin StyleNo := integer(FWordList.Objects[i]); TokenType := ttWord; break; end; From := toEnd + 1; end; //-------------------------------------------------------------- // SYNTAX MEMO - FIND LINE ATTRS //-------------------------------------------------------------- procedure TGLSSynHiMemo.FindLineAttrs(Sender: TObject; LineNo: integer; var Attrs: string); var i, From, TokenLen: integer; S, Token: string; TokenType: TTokenType; StyleNo, OldInBrackets: integer; OldInComment: Boolean; begin S := Lines[LineNo]; SetLength(Attrs, Length(S)); FInComment := InComment[LineNo]; FInBrackets := InBrackets[LineNo]; From := 1; while True do begin Token := GetToken(S, From, TokenType, StyleNo); if TokenType = ttEOL then break; TokenLen := Length(Token); for i := From - TokenLen to From - 1 do Attrs[i] := Char(StyleNo); end; if LineNo < Lines.Count - 1 then begin OldInComment := InComment[LineNo + 1]; OldInBrackets := InBrackets[LineNo + 1]; if OldInComment <> FInComment then begin InComment[LineNo + 1] := FInComment; ValidAttrs[LineNo + 1] := False; end; if OldInBrackets <> FInBrackets then begin InBrackets[LineNo + 1] := FInBrackets; ValidAttrs[LineNo + 1] := False; end; end; end; //-------------------------------------------------------------- // SYNTAX MEMO - ADD WORD //-------------------------------------------------------------- procedure TGLSSynHiMemo.AddWord(StyleNo: integer; const ArrS: array of string); var i: integer; begin for i := Low(ArrS) to high(ArrS) do FWordList.AddObject(ArrS[i], TObject(StyleNo)); end; //-------------------------------------------------------------- // SYNTAX MEMO - ADD SPECIAL //-------------------------------------------------------------- procedure TGLSSynHiMemo.AddSpecial(StyleNo: integer; const ArrS: array of string); var i: integer; begin for i := Low(ArrS) to high(ArrS) do FSpecialList.AddObject(ArrS[i], TObject(StyleNo)); end; //-------------------------------------------------------------- // SYNTAX MEMO - ADD BRACKETS //-------------------------------------------------------------- procedure TGLSSynHiMemo.AddBrackets(StyleNo: integer; const ArrS: array of string); var i: integer; begin for i := Low(ArrS) to high(ArrS) do FBracketList.AddObject(ArrS[i], TObject(StyleNo)); end; //-------------------------------------------------------------- // SYNTAX MEMO - CREATE //-------------------------------------------------------------- constructor TGLSSynHiMemo.Create(AOwner: TComponent); begin inherited; FInBrackets := -1; FIsPainting := False; FInComment := False; FWordList := TGLSMemoStringList.Create; FSpecialList := TGLSMemoStringList.Create; FBracketList := TGLSMemoStringList.Create; FDelimiterStyle := TCharStyle.Create; with FDelimiterStyle do begin TextColor := clBlue; BkColor := clWhite; Style := []; end; FCommentStyle := TCharStyle.Create; with FCommentStyle do begin TextColor := clYellow; BkColor := clSkyBlue; Style := [fsItalic]; end; FNumberStyle := TCharStyle.Create; with FNumberStyle do begin TextColor := clNavy; BkColor := clWhite; Style := [fsBold]; end; FDelimiterStyleNo := Styles.Add(clBlue, clWhite, []); FCommentStyleNo := Styles.Add(clSilver, clWhite, [fsItalic]); FNumberStyleNo := Styles.Add(clNavy, clWhite, [fsBold]); OnGetLineAttrs := FindLineAttrs; Delimiters := [' ', ',', ';', ':', '.', '(', ')', '{', '}', '[', ']', '=', '+', '-', '*', '/', '^', '%', '<', '>', '"', '''', #13, #10]; end; //-------------------------------------------------------------- // SYNTAX MEMO - DESTROY //-------------------------------------------------------------- destructor TGLSSynHiMemo.Destroy; begin FWordList.Free; FSpecialList.Free; FBracketList.Free; FDelimiterStyle.Free; FCommentStyle.Free; FNumberStyle.Free; inherited; end; // ---------------------TGLSMemoStringList procedure TGLSMemoStringList.ReadStrings(Reader: TReader); var i: Integer; begin try Reader.ReadListBegin; Clear; while not Reader.EndOfList do begin i := Add(Reader.ReadString); Objects[i] := TObject(Reader.ReadInteger); end; Reader.ReadListEnd; finally end; end; //-------------------------------------------------------------- // STRING LIST - WRITE STRINGS //-------------------------------------------------------------- procedure TGLSMemoStringList.WriteStrings(Writer: TWriter); var i: Integer; begin with Writer do begin WriteListBegin; for i := 0 to Count - 1 do begin WriteString(Strings[i]); WriteInteger(Integer(Objects[i])); end; WriteListEnd; end; end; //-------------------------------------------------------------- // STRING LIST - DEFINE PROPERTIES //-------------------------------------------------------------- procedure TGLSMemoStringList.DefineProperties(Filer: TFiler); begin Filer.DefineProperty('Strings', ReadStrings, WriteStrings, Count > 0); end; // ---------------------ScrollBar bitmaps procedure CreateScrollBarBitmaps; var i, j: integer; begin bmScrollBarFill := TBitmap.Create; with bmScrollBarFill, Canvas do begin Width := 8; Height := 8; Transparent := False; for i := 0 to 7 do for j := 0 to 7 do if Odd(i + j) then Pixels[i, j] := clSilver; end; bmScrollBarUp := TBitmap.Create; with bmScrollBarUp, Canvas do begin Width := 7; Height := 8; Brush.Color := clSilver; FillRect(Rect(0, 0, Width, Height)); Pixels[3, 2] := clBlack; MoveTo(2, 3); LineTo(5, 3); MoveTo(1, 4); LineTo(6, 4); MoveTo(0, 5); LineTo(7, 5); end; bmScrollBarDown := TBitmap.Create; with bmScrollBarDown, Canvas do begin Width := 7; Height := 8; Brush.Color := clSilver; FillRect(Rect(0, 0, Width, Height)); MoveTo(0, 2); LineTo(7, 2); MoveTo(1, 3); LineTo(6, 3); MoveTo(2, 4); LineTo(5, 4); Pixels[3, 5] := clBlack; end; bmScrollBarLeft := TBitmap.Create; with bmScrollBarLeft, Canvas do begin Width := 8; Height := 7; Brush.Color := clSilver; FillRect(Rect(0, 0, Width, Height)); Pixels[2, 3] := clBlack; MoveTo(3, 2); LineTo(3, 5); MoveTo(4, 1); LineTo(4, 6); MoveTo(5, 0); LineTo(5, 7); end; bmScrollBarRight := TBitmap.Create; with bmScrollBarRight, Canvas do begin Width := 8; Height := 7; Brush.Color := clSilver; FillRect(Rect(0, 0, Width, Height)); MoveTo(2, 0); LineTo(2, 7); MoveTo(3, 1); LineTo(3, 6); MoveTo(4, 2); LineTo(4, 5); Pixels[5, 3] := clBlack; end; end; //------------------ FREE SCROLL BAR BITMAPs ------------------- procedure FreeScrollBarBitmaps; begin bmScrollBarFill.Free; bmScrollBarUp.Free; bmScrollBarDown.Free; bmScrollBarLeft.Free; bmScrollBarRight.Free; end; //---------------------------------- initialization //---------------------------------- RegisterClasses([TGLSSynHiMemo]); CreateScrollBarBitmaps; IntelliMouseInit; //---------------------------------- finalization //---------------------------------- FreeScrollBarBitmaps; end.