infomemo.pas

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

// TimFormattedRange -----------------------------------------------------------

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

// TimNormalFormattedRange -----------------------------------------------------

 TimNormalFormattedRange = class(TimCustomFormattedRange)
 protected
  function GetColor: TColor; override;
  function GetFont: TFont; override;
 end;


// TimMCRanges -----------------------------------------------------------------

 TsmRangeClass = class of TimCustomRange;

 TimMCRanges = class(TimObjectContainer)
 private
  FItemClass: TsmRangeClass;
  function NewGetOwner: TInfoMemo;
 protected
  procedure NewSetItem(ItemIndex: Integer; const Value: TimCustomRange);
  function NewGetItem(ItemIndex: Integer): TimCustomRange;
 public
  constructor Create(AOwner: TInfoMemo);
  function Add: TimCustomRange; overload;
  function Add(Start, Count: Integer): TimCustomRange; overload;
  property ItemClass: TsmRangeClass read FItemClass write FItemClass;
  property Items[ItemIndex: Integer]: TimCustomRange read NewGetItem write NewSetItem;
  property Owner: TInfoMemo read NewGetOwner;
 end;

// TimIntegerList --------------------------------------------------------------

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

function imTextCell(CellRow, CellCol: Integer): TimTextCell;

implementation

uses RTLConsts, ClipBrd, imTextAttribute;

const
MaxScrollTolerance = 2;

procedure TabPosAdjust(var CurPos: Integer; TabSize: Integer);
begin
 inc(CurPos,TabSize);
end;

// TEditExpStrings Definition --------------------------------------------------

type
 TInfoMemoStrings = class(TStrings)
 private
  FNotepad: TInfoMemo;
  FAttributeLines : TimAttributeLines;
 protected
  function Get(LineIndex: Integer): string; override;
  function GetCount: Integer; override;
  function GetTextStr: string; override;
  procedure Put(LineIndex: Integer; const S: string); override;
  procedure SetTextStr(const Value: string); override;
 public
  constructor Create; virtual;
  destructor Destroy; override;
  procedure Clear; override;
  procedure Delete(LineIndex: Integer); override;
  procedure Insert(LineIndex: Integer; const S: string); override;
  procedure InsertStringToLine(LineIndex,StringPos: Integer; const S: string);
  procedure ReplaceStringToLine(LineIndex,StringPos: Integer; const S: string);
  function GetStringFromLine(LineIndex,StringPos: Integer): string;
  property AttributeLines : TimAttributeLines read FAttributeLines;
 end;

// Helper Functions

function imTextCell(CellRow, CellCol: Integer): TimTextCell;
begin
 with Result do begin
  Row := CellRow;
  Col := CellCol;
 end;
end;

// TInfoMemo --------------------------------------------------------------------

procedure TInfoMemo.CellFromScrCol(var Cell: TimTextCell);
var
 I,
 Col,
 Count: Integer;
begin
 if Cell.Row < 1 then
  Cell.Row := 1;
 if Cell.Row > LineCount then
  Cell.Row := LineCount;
 if TabSize <> 1 then begin
  Count := 0;
  I := CellToCharIdx(imTextCell(Cell.Row, 1));
  Col := Cell.Col;
  Cell.Col := 1;
  while Count < Col do begin
   if (I <= TextLength) and (Text[I] = #9) then
    TabPosAdjust(Count,TabSize)
   else
    Inc(Count);
   if Count < Col then begin
    Inc(I);
    Inc(Cell.Col);
   end;
  end;
 end;
 if Cell.Col < 1 then
  Cell.Col := 1;
 if Cell.Col > LineLength[Cell.Row] + 1 then
  Cell.Col := LineLength[Cell.Row] + 1;
end;

function TInfoMemo.CellFromScrColToScrCol(var Cell: TimTextCell): Integer;
var
 I,
 Col,
 Count: Integer;
begin
 if Cell.Row < 1 then Cell.Row := 1;
 if Cell.Row > LineCount then Cell.Row := LineCount;
 if TabSize = 1 then
  Result := Cell.Col
 else begin
  Result := 1;
  Count := 0;
  I := CellToCharIdx(imTextCell(Cell.Row, 1));
  Col := Cell.Col;
  Cell.Col := 1;
  while Count < Col do begin
   Result := Count + 1;
   if (I <= TextLength) and (Text[I] = #9) then
    TabPosAdjust(Count,TabSize)
   else
    Inc(Count);
   if Count < Col then begin
    Inc(I);
    Inc(Cell.Col);
   end;
  end;
 end;
 if Cell.Col < 1 then Cell.Col := 1;
 if Cell.Col > LineLength[Cell.Row] + 1 then Cell.Col := LineLength[Cell.Row] + 1;
end;

function TInfoMemo.CellToCharIdx(Cell: TimTextCell): Integer;
begin
 with Cell do
  if Row <= 0 then
   Result := Col
  else
  if Row > LineCount then
   Result := TextLength + 2 + Col
  else
   Result := FLineStarts.Items[Row - 1] + Col - 1;
end;

function TInfoMemo.CellToScrCol(Cell: TimTextCell): Integer;
var
 I,
 Idx: Integer;
begin
 if TabSize = 1 then
  Result := Cell.Col
 else begin
  Result := 0;
  Idx := CellToCharIdx(imTextCell(Cell.Row, 1));
  for I := Idx to Idx + Cell.Col - 2 do begin
   if (I > 0) and (I <= TextLength) and (Text[I] = #9) then
    TabPosAdjust(Result,TabSize)
   else
    Inc(Result);
  end;
  Inc(Result);
 end;
end;

procedure TInfoMemo.Change;
begin
 if not DontNotify then begin
  inherited Changed;
  if Assigned(FOnChange) then
   FOnChange(Self);
  if Assigned(FOnChangePrivate) then
   FOnChangePrivate(Self);
 end;
end;

procedure TInfoMemo.ChangeIndent(Change: Integer);
var
I, RS, RE, L, CurPos: Integer;
begin
 if Change <> 0 then begin
  DontNotify := True;
  VisibleRange.DoChanging;
  MakeUndoOperation(CreateUndoBeginEndBlock);
  RS := Selection.StartRowCol.Row;
  RE := Selection.EndRowCol.Row;
  if RE < RS then
   RE := RS;
  for I := RS to RE do begin
   CurPos := CellToCharIdx(imTextCell(I, 1));
   if Change > 0 then begin
    while (CurPos <= TextLength) and (Text[CurPos] in [#9, #21]) do
     Inc(CurPos);
    L := Change;
    with TimMCRange.Create(nil) do begin
     try
      Editor := Self;
      RStart := CurPos;
      RLength := 0;
      Text := StringOfChar(#9, L);
      if (Selection.RLength > 0) and (Selection.RStart = REnd + 1) then
       Selection.RStart := RStart;
     finally
      Free;
     end
    end;
   end else begin
    L := 0;
    while (CurPos <= TextLength) and (Text[CurPos] in [#9, #21]) do begin
     Inc(CurPos);
     Inc(L);
    end;
    if L > -Change then
     L := -Change;
    with TimMCRange.Create(nil) do begin
     try
      Editor := Self;
      RStart := CurPos - L;
      REnd := CurPos - 1;
      Text := '';
     finally
      Free;
     end;
    end;
   end;
  end;
  MakeUndoOperation(CreateUndoBeginEndBlock);
  VisibleRange.DoDiscardChanges;
  Selection.HideCaret;
  VisibleRange.DrawRange;
  Selection.UpdateCaretPos;
  Selection.ShowCaret;
  DontNotify := False;
  Self.Change;
  SelectionChange;
 end;
end;

function TInfoMemo.CharIdxToCell(CharIdx: Integer): TimTextCell;
var
LineIdx: Integer;
begin
 with FLineStarts do begin
  if TextLength > 0 then
   LineIdx := Count * CharIdx div TextLength - 1
  else
   LineIdx := 0;
  if LineIdx < 0 then LineIdx := 0;
  if LineIdx >= Count then LineIdx := Count - 1;
  while (LineIdx < Count - 1) and (Items[LineIdx] < CharIdx) do
   Inc(LineIdx);
  while (LineIdx > 0) and (Items[LineIdx] > CharIdx) do
   Dec(LineIdx);
  with Result do begin
   Row := LineIdx + 1;
   Col := CharIdx - Items[LineIdx] + 1;
  end;
 end;
end;

procedure TInfoMemo.Clear;
begin
 Text := '';
end;

procedure TInfoMemo.ClearRedo;
begin
 while CanRedo do GetLastRedo;
end;

procedure TInfoMemo.ClearSelection;
begin
 Perform(wm_Clear,0,0);
end;

procedure TInfoMemo.ClearUndo;
begin
 while CanRedo do GetLastRedo;
 while CanUndo do GetLastUndo;
 Change;
end;

procedure TInfoMemo.ClearUndoRedo;
begin
 FreeUndoRedoBuffer;
 Change;
end;

procedure TInfoMemo.FreeUndoRedoBuffer;
var
P : PimUndoOperation;
begin
 while Assigned(FRedoStack) do begin
  P := FRedoStack^.NextItem;
  Dispose(FRedoStack);
  FRedoStack := P;
 end;
 while Assigned(FUndoStack) do begin
  P := FUndoStack^.NextItem;
  Dispose(FUndoStack);
  FUndoStack := P;
 end;
end;

procedure TInfoMemo.CMFontChanged(var Message: TMessage);
begin
 inherited;
 UpdateFontSize;
end;

procedure TInfoMemo.CMWantSpecialKey(var Message: TCMWantSpecialKey);
begin
 inherited;
 if not (csDesigning in ComponentState) then
  if Message.CharCode in [vk_Left, vk_Right, vk_Up, vk_Down, vk_Prior, vk_Next,
                          vk_Home, vk_End, vk_Tab, vk_Clear, vk_Delete, vk_Insert] then
   Message.Result := 1;
end;

procedure TInfoMemo.CopyToClipboard;
begin
 Perform(wm_Copy, 0, 0);
end;

constructor TInfoMemo.Create(AOwner: TComponent);
begin
 inherited;
 FBitmapped := False;
 FText := '';
 FLineStarts := TimIntegerList.Create;
 FLineStarts.Add(1);
 FLines := TInfoMemoStrings.Create;
 TInfoMemoStrings(FLines).FNotepad := Self;
 FTrackedRanges := TimMCRanges.Create(Self);
 FWholeText := TimWholeTextRange.Create(nil);
 FWholeText.Editor := Self;
 FVisibleRange := TimVisibleRange.Create(TrackedRanges);
 FSelection := TimSelectionRange.Create(TrackedRanges);
 FTabSize := 2;
 FScrollBars := ssNone;
 FBorderStyle := bsSingle;
 FLeftMargin := 2;
 FTopMargin := 0;
 FPasswordChar := #0;
 FCharCase := ecNormal;
 FHideSelection := True;
 FOpenTimeCall := False;
 FTimeEnabled := False;
 FIsKeyChange := False;
 ControlStyle := ControlStyle + [csOpaque] - [csNoStdEvents];
 DoubleBuffered := False;
 Constraints.MinWidth := 32;
 Constraints.MinHeight := 38;
 TabStop := True;
 ParentColor := False;
 Color := clWindow;
 Font.Name := 'Courier New';
 Font.Size := 8;
 Width := 185;
 Height := 89;
 FThreshold := 3;
 FMouseWheelVScrollSize := 3;
 FVolatileForeColor := Font.Color;
 FVolatileBackColor := Brush.Color;
 FUseVolatileColor := False;
 FAlignment := taLeftJustify;
 FWordWrap := False;
end;

procedure TInfoMemo.CreateParams(var Params: TCreateParams);
const
Alignments: array[Boolean, TAlignment] of DWORD = ((ES_LEFT, ES_RIGHT, ES_CENTER),(ES_RIGHT, ES_LEFT, ES_CENTER));
WordWraps: array[Boolean] of DWORD = (0, ES_AUTOHSCROLL);
ScrollBar: array[TScrollStyle] of DWORD = (0,WS_HSCROLL,WS_VSCROLL,WS_HSCROLL or WS_VSCROLL);
BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);
Passwords: array[Boolean] of DWORD = (0, ES_PASSWORD);
ReadOnlys: array[Boolean] of DWORD = (0, ES_READONLY);
CharCases: array[TEditCharCase] of DWORD = (0, ES_UPPERCASE, ES_LOWERCASE);
HideSelections: array[Boolean] of DWORD = (ES_NOHIDESEL, 0);
OEMConverts: array[Boolean] of DWORD = (0, ES_OEMCONVERT);
begin
 inherited CreateParams(Params);
 with Params do begin
  Style := Style and not WordWraps[FWordWrap] or ES_MULTILINE or
           Alignments[UseRightToLeftAlignment, FAlignment] or ScrollBar[FScrollBars];
  Style := Style or (ES_AUTOHSCROLL or ES_AUTOVSCROLL) or
           BorderStyles[FBorderStyle] or Passwords[FPasswordChar <> #0] or