infomemo.pas

Delphi中一直都没有能快速显示彩色文字信息的Memo控件而TRichEdit慢得无法在需要高速的场合使用

{*********************************************************}
{       TMemo-Compatible Component v1.0                   }
{       Copyright (c) 2000 Sebastian Reichelt             }
{---------------------------------------------------------}
{ InfoMemo v1.0 Reprogram from TMemo-Compatible Component }
{ zhang jin-song www.ynu.edu.cn                           }
{*********************************************************}

unit InfoMemo;
{$R-,T-,H+,X+}

interface

uses
 Windows, Messages, SysUtils, Classes, Forms, Graphics, Controls, StdCtrls,
 imObjList;

type
 TimMCRanges = class;
 TimCustomRange = class;
 TimMCRange = class;
 TimWholeTextRange = class;
 TimVisibleRange = class;
 TimSelectionRange = class;
 TimCustomFormattedRange = class;
 TimFormattedRange = class;
 TimNormalFormattedRange = class;

 TimFormattedRangeArray = array of TimCustomFormattedRange;

 TimIntegerList = class;

 TimTextCell = record
  Row : Integer;
  Col : Integer;
 end;

 PimUndoOperation = ^TimUndoOperation;
 TimUndoOperation = record
  RStart,
  REnd: Integer;
  NewText: string;
  NextItem: PimUndoOperation;
 end;

// TNotepad --------------------------------------------------------------------

 TInfoMemo = class(TCustomControl)
 private
  FHasFocus : Boolean;
  FCaretPixelPos : TPoint;
  FCaretCreated : Boolean;
  FReadOnly : Boolean;
  FWordWrap : Boolean;
  FBitmapped : Boolean;
  FOEMConvert : Boolean;
  FHideSelection : Boolean;
  FUseVolatileColor : Boolean;
  FAlwaysShowCaret : Boolean;
  FOpenTimeCall : Boolean;
  FTimeEnabled : Boolean;
  FIsKeyChange : Boolean;
  FPasswordChar : Char;
  FThreshold : Integer;
  FMouseWheelVScrollSize : Integer;
  FLongestLineLength : Integer;
  FTabSize : Integer;
  FTopMargin : Integer;
  FLeftMargin : Integer;
  FTextLength : Integer;
  FSelStartPos : TPoint;
  FVolatileForeColor : TColor;
  FVolatileBackColor : TColor;
  FText : TCaption;
  FLines : TStrings;
  FLineStarts : TimIntegerList;
  FCharCase : TEditCharCase;
  FAlignment : TAlignment;
  FBorderStyle : TBorderStyle;
  FScrollBars : TScrollStyle;
  FSelection : TimSelectionRange;
  FVisibleRange : TimVisibleRange;
  FTrackedRanges : TimMCRanges;
  FWholeText : TimCustomRange;
  FOnChange : TNotifyEvent;
  FOnChangePrivate : TNotifyEvent;
  FOnSelectionChange : TNotifyEvent;
  procedure CMFontChanged(var Message: TMessage); message cm_FontChanged;
  procedure WMSize(var Message: TWMSize); message wm_Size;
  procedure WMHScroll(var Message: TWMHScroll); message wm_HScroll;
  procedure WMVScroll(var Message: TWMVScroll); message wm_VScroll;
  procedure WMMouseWheel(var Message: TWMMouseWheel); message WM_MOUSEWHEEL;
  procedure WMSetFocus(var Message: TWMSetFocus); message wm_SetFocus;
  procedure WMKillFocus(var Message: TWMKillFocus); message wm_KillFocus;
  procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message wm_EraseBkgnd;
  procedure CMWantSpecialKey(var Message: TCMWantSpecialKey); message cm_WantSpecialKey;
  procedure WMClear(var Message: TWMClear); message wm_Clear;
  procedure WMCut(var Message: TWMCut); message wm_Cut;
  procedure WMCopy(var Message: TWMCopy); message wm_Copy;
  procedure WMPaste(var Message: TWMPaste); message wm_Paste;
  procedure WMSetText(var Message: TWMSetText); message wm_SetText;
  procedure WMGetText(var Message: TWMGetText); message wm_GetText;
  procedure WMGetTextLength(var Message: TWMGetTextLength); message wm_GetTextLength;
  procedure WMTimer(var Message: TWMTimer); message wm_Timer;
  procedure EMUndo(var Message: TMessage); message em_Undo;
  procedure EMCanUndo(var Message: TMessage); message em_CanUndo;
  procedure SetText(const Value: TCaption);
  procedure SetScrollBars(const Value: TScrollStyle);
  procedure SetBorderStyle(const Value: TBorderStyle);
  procedure SetReadOnly(const Value: Boolean);
  procedure SetLines(const Value: TStrings);
  procedure SetSelLength(const Value: Integer);
  procedure SetSelStart(const Value: Integer);
  procedure SetAlwaysShowCaret(const Value: Boolean);
  procedure SetLeftMargin(const Value: Integer);
  procedure SetTopMargin(const Value: Integer);
  procedure SetTabSize(const Value: Integer);
  procedure SetBitmapped(const Value: Boolean);
  procedure FreeUndoRedoBuffer;
  procedure SetOEMConvert(Value: Boolean);
  procedure SetCharCase(Value: TEditCharCase);
  procedure SetHideSelection(Value: Boolean);
  procedure SetPasswordChar(Value: Char);
  procedure SetAlignment(Value: TAlignment);
  procedure SetWordWrap(Value: Boolean);
  function GetLineCount: Integer;
  function GetLineLength(LineIndex: Integer): Integer;
  function GetVisualLineLength(LineIndex: Integer): Integer;
  function GetSelLength: Integer;
  function GetSelStart: Integer;
  function GetCanRedo: Boolean;
  function GetCanUndo: Boolean;
 protected
  FontHeight,
  FontWidth,
  PageHeight,
  PageWidth : Integer;
  DrawBmp : TBitmap;
  FUndoStack,
  FRedoStack : PimUndoOperation;
  FInUndo,
  DontNotify : Boolean;
  procedure CreateParams(var Params: TCreateParams); override;
  procedure CreateWnd; override;
  procedure ReplaceText(Range: TimCustomRange; const NewText: string); virtual;
  procedure DrawTextLine(Range: TimCustomRange; Left, Top: Integer; NextTabStop: Integer); virtual;
  procedure StandardDrawTo(Range : TimCustomFormattedRange; var R: TRect; NextTabStop: Integer);
  procedure AttributeDrawTo(Range : TimCustomFormattedRange; var R: TRect; NextTabStop: Integer);
  procedure DrawBorder(LeftRect, TopRect: TRect; Canvas: TCanvas); virtual;
  procedure TextChangeNotification(StartPos,OldLength,NewLength: Integer; const NewText: string;
                                   Before: Boolean); dynamic;
  function  GetTabCharSize(const S: string): Integer;
  procedure Change; dynamic;
  procedure SelectionChange; dynamic;
  procedure UpdateFontSize; virtual;
  procedure UpdatePageSize; virtual;
  procedure UpdateDrawBmp; virtual;
  procedure ReCreateCaret; virtual;
  procedure FreeCaret; virtual;
  procedure Paint; 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 KeyPress(var Key: Char); override;
  procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  procedure MakeUndoOperation(Op: PimUndoOperation); virtual;
  procedure MakeRedoOperation(Op: PimUndoOperation); virtual;
  procedure SetInsLine(LineIndex,StringPos: Integer; const S: string);
  procedure SetRepLine(LineIndex,StringPos: Integer; const S: string);
  function GetLine(LineIndex,StringPos: Integer): string;
  function GetLastUndo: TimUndoOperation; virtual;
  function GetLastRedo: TimUndoOperation; virtual;
  function CreateUndoBeginEndBlock: PimUndoOperation; virtual;
  function CreateSplitRanges(Range: TimCustomRange): TimFormattedRangeArray; virtual;
  function IsUndoBeginEndBlock(Op: PimUndoOperation): Boolean; virtual;
 public
  constructor Create(AOwner: TComponent); override;
  destructor Destroy; override;
  procedure Clear; virtual;
  procedure CellFromScrCol(var Cell: TimTextCell); virtual;
  procedure SelectAll;
  procedure ClearSelection;
  procedure CutToClipboard;
  procedure CopyToClipboard;
  procedure PasteFromClipboard;
  procedure Undo;
  procedure Redo;
  procedure ClearUndo;
  procedure ClearRedo;
  procedure ClearUndoRedo;
  procedure ScrollCaret(LinePos: Integer); virtual;
  procedure ChangeIndent(Change: Integer); virtual;
  procedure SetLineAttributeEx(Index,First,Last: Integer; ForeColor,BackColor: TColor;
                               FontStyles: TFontStyles; NowDraw : Boolean);
  procedure SetLineAttribute(Index,First,Last: Integer; ForeColor,BackColor: TColor;
                             FontStyles: TFontStyles; NowDraw : Boolean);
  function CharIdxToCell(CharIdx: Integer): TimTextCell; virtual;
  function CellToCharIdx(Cell: TimTextCell): Integer; virtual;
  function ScrPointToScrCell(P: TPoint): TimTextCell; virtual;
  function ScrCellToScrPoint(Cell: TimTextCell): TPoint; virtual;
  function ScrXToCol(X: Integer): Integer;
  function TabSpacesAtPos(P: Integer): Integer; virtual;
  function CellToScrCol(Cell: TimTextCell): Integer; virtual;
  function CellFromScrColToScrCol(var Cell: TimTextCell): Integer; virtual;
  function GetLineOffset(Row: Integer): Integer;
  property Text: TCaption read FText write SetText;
  property TextLength: Integer read FTextLength;
  property TrackedRanges: TimMCRanges read FTrackedRanges;
  property WholeText: TimCustomRange read FWholeText;
  property LineCount: Integer read GetLineCount;
  property LongestLineLength: Integer read FLongestLineLength;
  property LineLength[LineIndex: Integer]: Integer read GetLineLength;
  property VisualLineLength[LineIndex: Integer]: Integer read GetVisualLineLength;
  property VisibleRange: TimVisibleRange read FVisibleRange;
  property Selection: TimSelectionRange read FSelection;
  property SelStart: Integer read GetSelStart write SetSelStart;
  property SelLength: Integer read GetSelLength write SetSelLength;
  property CanUndo: Boolean read GetCanUndo;
  property CanRedo: Boolean read GetCanRedo;
  property OnChangePrivate: TNotifyEvent read FOnChangePrivate write FOnChangePrivate;
  property PasswordChar: Char read FPasswordChar write SetPasswordChar default #0;
  property CharCase: TEditCharCase read FCharCase write SetCharCase default ecNormal;
  property HideSelection: Boolean read FHideSelection write SetHideSelection default True;
  property OEMConvert: Boolean read FOEMConvert write SetOEMConvert default False;
  property VolatileForeColor : TColor read FVolatileForeColor write FVolatileForeColor default clBlack;
  property VolatileBackColor : TColor read FVolatileBackColor write FVolatileBackColor default clWhite;
  property UseVolatileColor : Boolean read FUseVolatileColor write FUseVolatileColor default False;
  property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
  property WordWrap: Boolean read FWordWrap write SetWordWrap default False;
  property MouseWheelVScrollSize : Integer read FMouseWheelVScrollSize write FMouseWheelVScrollSize default 3;
  property CaretPixelPos : TPoint read FCaretPixelPos;
  property InsLine[LineIndex,StringPos: Integer]: string read GetLine write SetInsLine;
  property RepLine[LineIndex,StringPos: Integer]: string read GetLine write SetRepLine;
  property Canvas;
 published
  property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars default ssNone;
  property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  property Bitmapped: Boolean read FBitmapped write SetBitmapped;
  property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  property OnChange: TNotifyEvent read FOnChange write FOnChange;
  property OnSelectionChange: TNotifyEvent read FOnSelectionChange write FOnSelectionChange;
  property Lines: TStrings read FLines write SetLines;
  property AlwaysShowCaret: Boolean read FAlwaysShowCaret write SetAlwaysShowCaret;
  property LeftMargin: Integer read FLeftMargin write SetLeftMargin;
  property TopMargin: Integer read FTopMargin write SetTopMargin;
  property TabSize: Integer read FTabSize write SetTabSize;
  property TabStop default True;
  property Align;
  property Anchors;
  property Color nodefault;
  property Constraints;
  property Ctl3D;
  property Enabled;
  property Font;
  property ParentColor;
  property ParentCtl3D;
  property ParentFont;
  property ParentShowHint;
  property PopupMenu;
  property ShowHint;
  property TabOrder;
  property Visible;
  property ImeMode;
  property ImeName;
  property Hint;
  property OnClick;
  property OnDblClick;
  property OnEnter;
  property OnExit;
  property OnKeyDown;
  property OnKeyPress;
  property OnKeyUp;
  property OnMouseDown;
  property OnMouseMove;
  property OnMouseUp;
 end;

// TimCustomRange --------------------------------------------------------------

 TimCustomRange = class(TimContainerItem)
 private
  FEditor: TInfoMemo;
  FChanging: Integer;
  FOnOverwrite: TNotifyEvent;
  FOnChange: TNotifyEvent;
  function GetEndPoint: TPoint;
  function GetStartPoint: TPoint;
 protected
  procedure SetRStart(const Value: Integer); virtual;
  procedure SetREnd(const Value: Integer); virtual;
  procedure SetRLength(const Value: Integer); virtual;
  procedure SetEndRowCol(const Value: TimTextCell); virtual;
  procedure SetStartRowCol(const Value: TimTextCell); virtual;
  procedure SetText(const Value: string); virtual;
  procedure Changing; dynamic;
  procedure Change; dynamic;
  procedure DiscardChanges; dynamic;
  function GetText: string; virtual;
  function GetRStart: Integer; virtual; abstract;
  function GetREnd: Integer; virtual; abstract;
  function GetRLength: Integer; virtual;
  function GetEndRowCol: TimTextCell; virtual;
  function GetStartRowCol: TimTextCell; virtual;
 public
  constructor Create(Collection: TCollection); override;
  procedure AssignTo(Dest: TPersistent); override;
  procedure NotifyOverwrite; dynamic;
  procedure DoChanging;
  procedure DoChange;
  procedure DoDiscardChanges;
  procedure Clear; virtual;
  procedure DrawRange; virtual;
  procedure ScrollInView(FromBorder: Integer); virtual;
  function CharInRange(CharIdx: Integer): Boolean;
  property Editor: TInfoMemo read FEditor write FEditor;
  property StartRowCol: TimTextCell read GetStartRowCol write SetStartRowCol;
  property EndRowCol: TimTextCell read GetEndRowCol write SetEndRowCol;
  property StartPoint: TPoint read GetStartPoint;
  property EndPoint: TPoint read GetEndPoint;
  property Text: string read GetText write SetText;
 published
  property RStart: Integer read GetRStart write SetRStart;
  property REnd: Integer read GetREnd write SetREnd;
  property RLength: Integer read GetRLength write SetRLength;
  property OnChange: TNotifyEvent read FOnChange write FOnChange;
  property OnOverwrite: TNotifyEvent read FOnOverwrite write FOnOverwrite;
 end;

// TimMCRange ------------------------------------------------------------------

 TimMCRange = class(TimCustomRange)
 private
  FRStart: Integer;
  FREnd: Integer;
 protected
  procedure SetREnd(const Value: Integer); override;
  procedure SetRStart(const Value: Integer); override;
  function GetREnd: Integer; override;
  function GetRStart: Integer; override;
 public
  constructor Create(Collection: TCollection); override;
 end;

// TimWholeTextRange -----------------------------------------------------------

 TimWholeTextRange = class(TimCustomRange)
 protected
  function GetREnd: Integer; override;
  function GetRStart: Integer; override;
 end;

// TimVisibleRange -------------------------------------------------------------

 TimVisibleRange = class(TimCustomRange)
 private
  FLeftCol: Integer;
  FTopRow: Integer;
  function GetRightCol: Integer;
  procedure SetRightCol(const Value: Integer);
  procedure SetLeftCol(const Value: Integer);
  procedure Update;
 protected
  VisibleTextRect: TRect;
  procedure SetRStart(const Value: Integer); override;
  procedure SetREnd(const Value: Integer); override;
  procedure SetRLength(const Value: Integer); override;
  procedure SetStartRowCol(const Value: TimTextCell); override;
  procedure SetEndRowCol(const Value: TimTextCell); override;
  procedure Changing; override;
  procedure Change; override;
  function GetRStart: Integer; override;
  function GetREnd: Integer; override;
  function GetStartRowCol: TimTextCell; override;
  function GetEndRowCol: TimTextCell; override;
 public
  constructor Create(Collection: TCollection); override;
 published
  property LeftCol: Integer read FLeftCol write SetLeftCol;
  property RightCol: Integer read GetRightCol write SetRightCol;
 end;

// TimSelectionRange -----------------------------------------------------------

 TimSelectionRange = class(TimMCRange)
 private
  FOldSel: TimCustomRange;
  FBackwards: Boolean;
  FHidden: Boolean;
  FCaretShowing: Boolean;
  FScrCol: Integer;
  procedure SetCursorPos(const Value: Integer);
  procedure SetHidden(const Value: Boolean);
  function GetScrCol: Integer;
  function GetCursorPos: Integer;
 protected
  procedure Changing; override;
  procedure Change; override;
  procedure DiscardChanges; override;
 public
  procedure AssignTo(Dest: TPersistent); override;
  procedure NoSelAtPos(Pos: Integer);
  procedure UpdateCaretPos;
  procedure ShowCaret;
  procedure HideCaret;
  function ScrColToCol(Row: Integer): Integer;
  property CursorPos: Integer read GetCursorPos write SetCursorPos;
  property ScrCol: Integer read GetScrCol write FScrCol;
 published
  property Backwards: Boolean read FBackwards write FBackwards;
  property Hidden: Boolean read FHidden write SetHidden;
 end;

// TimCustomFormattedRange -----------------------------------------------------

 TimFormattedRangeType = (frtNormal,frtSelect,frtSyntax);

 TimCustomFormattedRange = class(TimMCRange)
 protected
  FFormattedRangeType : TimFormattedRangeType;
  procedure SetColor(const Value: TColor); virtual;
  procedure SetFont(const Value: TFont); virtual;
  function GetColor: TColor; virtual; abstract;
  function GetFont: TFont; virtual; abstract;
 public
  FreeWhenDone: Boolean;
  constructor Create(Collection: TCollection); override;
  procedure AssignTo(Dest: TPersistent); override;
  property FormattedRangeType : TimFormattedRangeType read FFormattedRangeType
                                                     write FFormattedRangeType default frtNormal;
 published
  property Color: TColor read GetColor write SetColor;
  property Font: TFont read GetFont write SetFont;
 end;