memocomponentunit.pas

这是一个有关文本编辑器的源程序,支持彩色语法,你可以任意修改,修改后发给我一份

{*******************************************************}
{                                                       }
{       TMemo-Compatible Component v1.11                 }
{                                                       }
{       Copyright (c) 2000-2002 Sebastian Reichelt      }
{                                                       }
{*******************************************************}

unit MemoComponentUnit;

interface

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

type
	TMCRanges = class;
	TCustomRange = class;
	TMCRange = class;
	TWholeTextRange = class;
	TVisibleRange = class;
	TSelectionRange = class;
	TCustomFormattedRange = class;
	TFormattedRange = class;
	TNormalFormattedRange = class;

	TFormattedRangeArray = array of TCustomFormattedRange;

	TIntegerList = class;

	TTextCell = record
		Row,
		Col: Integer;
	end;

	PUndoOperation = ^TUndoOperation;
	TUndoOperation = record
		RStart,
		REnd: Integer;
		NewText: string;
		NextItem: PUndoOperation;
	end;

	TReplaceEvent = procedure(Sender: TObject; Pos, Change: Integer) of object;

	{	Note:
		The key element of the TMemoComponent class is the ReplaceText
		method.  Its intent is to replace a piece of text (range) with as
		little destruction as possible.  All values, for example the line
		index table and tracked ranges, are kept intact.  Do not attempt to
		call this procedure directly or to modify the memo's text directly
		using FText.  Instead, create a range and use its Text property.
		The range can be tracked or not, but be sure to set the Editor
		property if it is not tracked.
		To change the behavior when drawing text, override the virtual
		CreateSplitRanges method.  The result must be an array of
		TCustomFormattedRange }

	TMemoComponent = class(TCustomControl)
	private
		FHasFocus: Boolean;
		FCaretCreated: Boolean;
		FSelecting: Boolean;
		FDragging: Boolean;
		FStartDrag: Boolean;
		FDblClicked: Boolean;
		FLineStarts: TIntegerList;
		FScrollBars: TScrollStyle;
		FBorderStyle: TBorderStyle;
		FReadOnly: Boolean;
		FOnChange: TNotifyEvent;
		FText: TCaption;
		FTrackedRanges: TMCRanges;
		FWholeText: TCustomRange;
		FLines: TStrings;
		FVisibleRange: TVisibleRange;
		FSelection: TSelectionRange;
		FLongestLineLength: Integer;
		FAlwaysShowCaret: Boolean;
		FLeftMargin: Integer;
		FTopMargin: Integer;
		FTabSize: Integer;
		FOnSelectionChange: TNotifyEvent;
		FTextLength: Integer;
		FBitmapped: Boolean;
		FOnChangePrivate: TNotifyEvent;
		FAllowUndo: Boolean;
		FOnReplaceText: TReplaceEvent;
		FForbiddenFontStyles: TFontStyles;
		FDrawingSuspended: Boolean;
		FDragDropEditing: Boolean;
    FRemoveTrailingSpaces: Boolean;
		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 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 WMKeyDown(var Message: TWMKeyDown); message wm_KeyDown;
		procedure WMKeyUp(var Message: TWMKeyUp); message wm_KeyUp;
		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 CMMouseWheel(var Message: TCMMouseWheel); message cm_MouseWheel;
		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);
		function GetLineCount: Integer;
		function GetLineLength(LineIndex: Integer): Integer;
		function GetVisualLineLength(LineIndex: Integer): Integer;
		function GetSelLength: Integer;
		function GetSelStart: Integer;
		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);
		function GetCanRedo: Boolean;
		function GetCanUndo: Boolean;
		procedure SetBitmapped(const Value: Boolean);
		procedure SetAllowUndo(const Value: Boolean);
    procedure SetRemoveTrailingSpaces(const Value: Boolean);
	protected
		FontHeight,
		FontWidth,
		PageHeight,
		PageWidth: Integer;
		DrawBmp: TBitmap;
		FUndoStack,
		FRedoStack: PUndoOperation;
		FInUndo,
		DontNotify: Boolean;
		DragOrigRange: TMCRange;
		procedure CreateParams(var Params: TCreateParams); override;
		procedure CreateWnd; override;
		procedure ReplaceText(Range: TCustomRange; const NewText: string); virtual;
		procedure DrawTextLine(Range: TCustomRange; Left, Top: Integer; NextTabStop: Integer); virtual;
		function CreateSplitRanges(Range: TCustomRange): TFormattedRangeArray; virtual;
		procedure DrawBorder(LeftRect, TopRect: TRect; Canvas: TCanvas); virtual;
		procedure TextChangeNotification(StartPos, OldLength, NewLength: Integer); dynamic;
		procedure TextChangeNotificationAfter; dynamic;
		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 MouseMoveInternal(X, Y: Integer); virtual;
		procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
		procedure KeyPress(var Key: Char); override;
		procedure DblClick; override;
		function GetLastUndo: TUndoOperation; virtual;
		function GetLastRedo: TUndoOperation; virtual;
		function CreateUndoBeginEndBlock: PUndoOperation; virtual;
		function IsUndoBeginEndBlock(Op: PUndoOperation): Boolean; virtual;
		procedure MakeUndoOperation(Op: PUndoOperation); virtual;
		procedure MakeRedoOperation(Op: PUndoOperation); virtual;
		procedure CancelDragging;
	public
		constructor Create(AOwner: TComponent); override;
		destructor Destroy; override;
		procedure Clear; virtual;
		function CharIdxToCell(CharIdx: Integer): TTextCell; virtual;
		function CellToCharIdx(Cell: TTextCell): Integer; virtual;
		function ScrPointToScrCell(P: TPoint): TTextCell; virtual;
		function ScrCellToScrPoint(Cell: TTextCell): TPoint; virtual;
		function TabSpacesAtPos(P: Integer): Integer; virtual;
		function CellToScrCol(Cell: TTextCell): Integer; virtual;
		procedure CellFromScrCol(var Cell: TTextCell); virtual;
		function CellFromScrColToScrCol(var Cell: TTextCell): Integer; virtual;
		procedure SelectAll;
		procedure ClearSelection;
		procedure CutToClipboard;
		procedure CopyToClipboard;
		procedure PasteFromClipboard;
		procedure Undo;
		procedure Redo;
		procedure ClearUndo;
		procedure ClearRedo;
		procedure ScrollCaret; virtual;
		procedure ChangeIndent(Change: Integer); virtual;
		procedure RemoveTrSp;
		procedure RemoveTrSpFromLine(LineIdx: Integer);
		procedure RemoveTrSpFromString(var Str: string; IncludeLastLine: Boolean = False);
		property Text: TCaption read FText write SetText;
		property TextLength: Integer read FTextLength;
		property TrackedRanges: TMCRanges read FTrackedRanges;
		property WholeText: TCustomRange 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: TVisibleRange read FVisibleRange;
		property Selection: TSelectionRange read FSelection;
		property SelStart: Integer read GetSelStart write SetSelStart;
		property SelLength: Integer read GetSelLength write SetSelLength;
		property ForbiddenFontStyles: TFontStyles read FForbiddenFontStyles;
		property CanUndo: Boolean read GetCanUndo;
		property CanRedo: Boolean read GetCanRedo;
		property DrawingSuspended: Boolean read FDrawingSuspended write FDrawingSuspended;
		property OnReplaceText: TReplaceEvent read FOnReplaceText write FOnReplaceText;
		property OnChangePrivate: TNotifyEvent read FOnChangePrivate write FOnChangePrivate;
	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 AllowUndo: Boolean read FAllowUndo write SetAllowUndo default True;
		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 DragDropEditing: Boolean read FDragDropEditing write FDragDropEditing;
		property RemoveTrailingSpaces: Boolean read FRemoveTrailingSpaces write SetRemoveTrailingSpaces;
		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 OnClick;
		property OnDblClick;
		property OnEnter;
		property OnExit;
		property OnKeyDown;
		property OnKeyPress;
		property OnKeyUp;
		property OnMouseDown;
		property OnMouseMove;
		property OnMouseUp;
	end;

	TCustomRange = class(TFastContainerItem)
	private
		FEditor: TMemoComponent;
		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;
		function GetRStart: Integer; virtual; abstract;
		function GetREnd: Integer; virtual; abstract;
		function GetRLength: Integer; virtual;
		function GetEndRowCol: TTextCell; virtual;
		function GetStartRowCol: TTextCell; virtual;
		procedure SetEndRowCol(const Value: TTextCell); virtual;
		procedure SetStartRowCol(const Value: TTextCell); virtual;
		procedure SetText(const Value: string); virtual;
		function GetText: string; virtual;
		procedure Changing; dynamic;
		procedure Change; dynamic;
		procedure DiscardChanges; dynamic;
		procedure InternalDoMove(RangeStart, RangeEnd, LC: Integer); virtual;
	public
		constructor Create(Collection: TFastObjectContainer); override;
		procedure AssignTo(Dest: TPersistent); override;
		procedure NotifyOverwrite; dynamic;
		procedure DoChanging;
		procedure DoChange;
		procedure DoDiscardChanges;
		procedure Clear; virtual;
		function CharInRange(CharIdx: Integer): Boolean;
		procedure DrawRange; virtual;
		procedure ScrollInView(FromBorder: Integer); virtual;
		property Editor: TMemoComponent read FEditor write FEditor;
		property StartRowCol: TTextCell read GetStartRowCol write SetStartRowCol;
		property EndRowCol: TTextCell 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;

	TMCRange = class(TCustomRange)
	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;
		procedure InternalDoMove(RangeStart, RangeEnd, LC: Integer); override;
	public
		constructor Create(Collection: TFastObjectContainer); override;
	end;

	TWholeTextRange = class(TCustomRange)
	protected
		function GetREnd: Integer; override;
		function GetRStart: Integer; override;
	end;

	TVisibleRange = class(TCustomRange)
	private
		FLeftCol: Integer;
		FTopRow: Integer;
		procedure SetLeftCol(const Value: Integer);
		procedure SetRightCol(const Value: Integer);
		function GetRightCol: Integer;
		procedure SetTopRow(const Value: Integer);
		procedure SetBottomRow(const Value: Integer);
		function GetBottomRow: Integer;
	protected
		VisibleTextRect: TRect;
		procedure SetRStart(const Value: Integer); override;
		procedure SetREnd(const Value: Integer); override;
		procedure SetRLength(const Value: Integer); override;
		function GetRStart: Integer; override;
		function GetREnd: Integer; override;
		function GetStartRowCol: TTextCell; override;
		function GetEndRowCol: TTextCell; override;
		procedure SetStartRowCol(const Value: TTextCell); override;
		procedure SetEndRowCol(const Value: TTextCell); override;
		procedure Changing; override;
		procedure Change; override;
		procedure Update;
	public
		constructor Create(Collection: TFastObjectContainer); override;
	published
		property LeftCol: Integer read FLeftCol write SetLeftCol;
		property RightCol: Integer read GetRightCol write SetRightCol;
		property TopRow: Integer read FTopRow write SetTopRow;
		property BottomRow: Integer read GetBottomRow write SetBottomRow;
	end;

	TSelectionRange = class(TMCRange)
	private
		FOldSel: TCustomRange;
		FBackwards: Boolean;
		FHidden: Boolean;
		FCaretShowing: Boolean;
		FScrCol: Integer;
		function GetCursorPos: Integer;
		procedure SetCursorPos(const Value: Integer);
		procedure SetHidden(const Value: Boolean);
		function GetScrCol: Integer;
	protected
		procedure Changing; override;
		procedure Change; override;
		procedure DiscardChanges; override;
		procedure SetText(const Value: string); 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;

	TCustomFormattedRange = class(TMCRange)
	protected
		function GetColor: TColor; virtual; abstract;
		function GetFont: TFont; virtual; abstract;
		procedure SetColor(const Value: TColor); virtual;
		procedure SetFont(const Value: TFont); virtual;
	public
		FreeWhenDone: Boolean;
		procedure AssignTo(Dest: TPersistent); override;
		procedure CleanUpFont; virtual;
	published
		property Color: TColor read GetColor write SetColor;
		property Font: TFont read GetFont write SetFont;
	end;

	TFormattedRange = class(TCustomFormattedRange)
	private
		FFont: TFont;
		FColor: TColor;
	protected
		function GetColor: TColor; override;
		function GetFont: TFont; override;
		procedure SetColor(const Value: TColor); override;
		procedure SetFont(const Value: TFont); override;
	public
		constructor Create(Collection: TFastObjectContainer); override;
		destructor Destroy; override;
	end;

	TNormalFormattedRange = class(TCustomFormattedRange)
	protected
		function GetColor: TColor; override;
		function GetFont: TFont; override;
	end;

	TRangeClass = class of TCustomRange;

	TMCRanges = class(TFastObjectContainer)
	private
		FItemClass: TRangeClass;
		function NewGetOwner: TMemoComponent;
	protected
		function NewGetItem(ItemIndex: Integer): TCustomRange;
	public
		FDestroying: Boolean;
		constructor Create(AOwner: TMemoComponent);
		destructor Destroy; override;
		function Add: TCustomRange; overload;
		function Add(Start, Count: Integer): TCustomRange; overload;
		property ItemClass: TRangeClass read FItemClass write FItemClass;
		property Items[ItemIndex: Integer]: TCustomRange read NewGetItem;
		property Owner: TMemoComponent read NewGetOwner;
	end;

	TIntegerList = class(TObject)
	private
		FList: TList;
		function GetCount: Integer;
		function GetItem(ItemIndex: Integer): Integer;
		procedure SetItem(ItemIndex: Integer; const Value: Integer);
		procedure SetCount(const Value: Integer);
	public
		constructor Create;
		destructor Destroy; override;
		function Add(Item: Integer): Integer;
		procedure Insert(Index: Integer; Item: Integer);
		procedure Delete(Index: Integer);
		procedure Clear; dynamic;
		property Items[ItemIndex: Integer]: Integer read GetItem write SetItem;
		property Count: Integer read GetCount write SetCount;
	end;

function TextCell(CellRow, CellCol: Integer): TTextCell;

procedure Register;