infomemo.pas

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

  UpdateDrawBmp;
  Canvas.Draw(0,0,DrawBmp)
 end else begin
  DrawBorder(Rect(0,0,LeftMargin,ClientHeight),Rect(0,0,ClientWidth,TopMargin),Canvas);
  VisibleRange.DrawRange;
 end;
 Selection.ShowCaret;
end;

procedure TInfoMemo.PasteFromClipboard;
begin
 Perform(wm_Paste, 0, 0);
end;

procedure TInfoMemo.ReCreateCaret;
begin
 if FHasFocus and HandleAllocated then begin
  FreeCaret;
  CreateCaret(Handle,0,2,FontHeight);
  FCaretCreated := True;
  with Selection do begin
   UpdateCaretPos;
   ShowCaret;
  end;
 end;
end;

procedure TInfoMemo.Redo;
begin
 Perform(em_Undo, 1, 0);
end;

procedure TInfoMemo.ReplaceText(Range: TimCustomRange; const NewText: string);
var
RS, I, L, LI, EI, LC, P, PP, BC, RE, CurL, LnCh: Integer;
S : string;
BlUndo, PUN, RMod : Boolean;
Op: PimUndoOperation;
begin
 PUN := False;
 LnCh := 0;
 with Selection do begin
  DoChanging;
  FOldSel.Free;
  FOldSel := nil;
 end;
 RS := Range.RStart;
 S := AdjustLineBreaks(NewText);
 L := Length(S);
 //
 if not FInUndo then begin
  ClearRedo;
  BlUndo := False;
  Op := FUndoStack;
  if Assigned(Op) then begin
   if Range.RLength <= 0 then begin
    if (L > 0) and (Length(Op.NewText) <= 0) and (Op.REnd >= Op.RStart) then begin
     if Op.REnd + 1 = RS then begin
      Inc(Op.REnd,L);
      BlUndo := True;
     end;
    end;
   end else begin
    if (L <= 0) and (Length(Op.NewText) > 0) and (Op.REnd < Op.RStart) then begin
     if Op.RStart = RS then begin
      Op.NewText := Op.NewText + Range.Text;
      BlUndo := True;
     end else if Op.RStart = Range.REnd + 1 then begin
      Dec(Op.RStart, Range.RLength);
      Dec(Op.REnd, Range.RLength);
      Op.NewText := Range.Text + Op.NewText;
      BlUndo := True;
     end;
    end;
   end;
  end;
  if not BlUndo then begin
   New(Op);
   Op.RStart := RS;
   Op.REnd := RS + L - 1;
   Op.NewText := Range.Text;
   MakeUndoOperation(Op);
  end;
 end;
 //
 LI := CharIdxToCell(Range.RStart).Row;
 EI := CharIdxToCell(Range.REnd+1).Row;
 LC := L - Range.RLength;
 CurL := VisualLineLength[EI];
 if CurL >= FLongestLineLength then begin
  FLongestLineLength := 0;
  PUN := True;
 end;
 with FLineStarts do
  if (Range.RStart = 1) and (Range.REnd = TextLength) then begin
   LnCh := Count - 1;
   Clear;
   Add(1);
   FLongestLineLength := 0;
   PUN := True;
  end else
   for I := EI - 1 downto LI do begin
    if VisualLineLength[I + 1] >= FLongestLineLength then begin
     FLongestLineLength := 0;
     PUN := True;
    end;
    Delete(I);
    Dec(LnCh);
   end;

 Delete(FText, RS, Range.RLength);
 Insert(S, FText, RS);
 FTextLength := Length(FText);
 BC := 0;
 PP := 0;
 //
 repeat
  P := Pos(#13#10, S);
  if P > 0 then begin
   FLineStarts.Insert(LI + BC, Range.RStart + P + 1 + PP);
   Inc(LnCh);
   Delete(S,1,P + 1);
   Inc(PP,P + 1);
   Inc(BC);
  end;
 until P <= 0;
 //
 with FLineStarts do begin
  for I := LI + BC to Count - 1 do Items[I] := Items[I] + LC;
  if FLongestLineLength <= 0 then begin
   LI := 0;
   BC := Count - 1;
  end;
  for I := LI to LI + BC do begin
   if (I >= 0) and (I < Count) then begin
    P := VisualLineLength[I + 1];
    if P > FLongestLineLength then begin
     FLongestLineLength := P;
     PUN := True;
    end;
   end;
  end;
 end;

 with TrackedRanges do
  for I := Count - 1 downto 0 do
   if (Items[I] <> Range) and (Items[I] <> VisibleRange) then
    with Items[I] do begin
     DoChanging;
     RMod := False;
     if LC > 0 then begin
      if (REnd >= Range.RStart) and (REnd <= Range.REnd) then begin
       if RStart > Range.RStart then
        RStart := Range.RStart;
       REnd := Range.RStart - 1;
       RMod := True;
      end else
       if REnd > Range.REnd then
        REnd := REnd + LC;
      if (RStart >= Range.RStart) and (RStart <= Range.REnd) then begin
       RStart := Range.RStart;
       RMod := True;
      end else
       if RStart > Range.REnd then
        RStart := RStart + LC;
     end else begin
      RE := REnd;
      if (RStart >= Range.RStart) and (RStart <= Range.REnd) then begin
       RStart := Range.RStart;
       RMod := True;
      end else
       if RStart > Range.REnd then
        RStart := RStart + LC;
      if (RE >= Range.RStart) and (RE <= Range.REnd) then begin
       if RStart > Range.RStart then
        RStart := Range.RStart;
       REnd := Range.RStart - 1;
       RMod := True;
      end else
       if RE > Range.REnd then
        REnd := RE + LC;
     end;
     DoChange;
     if RMod and (RLength <= 0) then
      NotifyOverwrite;
    end;
 //
 if (LnCh <> 0) and (not FIsKeyChange) then begin
  with VisibleRange do
  if LI < StartRowCol.Row then Inc(VisibleRange.FTopRow,LnCh);
 end;
 //
 if Range is TimSelectionRange then begin
  TimSelectionRange(Range).NoSelAtPos(RS + L);
 end else
  Range.RLength := L;
 TextChangeNotification(RS,L - LC,L,NewText,True);
 if PUN or (LnCh <> 0) then begin
  UpdatePageSize;
 end else begin
  with TimMCRange.Create(nil) do begin
   Editor := Self;
   RStart := RS - 1;
   EndRowCol := imTextCell(LI + 1, 0);
   DrawRange;
   Free;
  end;
 end;
 TextChangeNotification(RS,L - LC,L,NewText,False);
 Selection.DoChange;
 Change;
end;

function TInfoMemo.ScrCellToScrPoint(Cell: TimTextCell): TPoint;
begin
 with Cell do
  Result := Point((Col - 1) * FontWidth + LeftMargin,(Row - 1) * FontHeight + TopMargin);
end;

procedure TInfoMemo.ScrollCaret(LinePos: Integer);
begin
 Selection.ScrollInView(LinePos);
end;

function TInfoMemo.ScrPointToScrCell(P: TPoint): TimTextCell;
begin
 with P do
  Result := imTextCell((Y - TopMargin) div FontHeight + 1,
                            (X - LeftMargin + FontWidth div 2) div FontWidth + 1);
end;

procedure TInfoMemo.SelectAll;
begin
 Selection.Assign(WholeText);
end;

procedure TInfoMemo.SelectionChange;
begin
 if not DontNotify then begin
  if Assigned(FOnSelectionChange) then
   FOnSelectionChange(Self);
 end;
end;

procedure TInfoMemo.SetAlwaysShowCaret(const Value: Boolean);
begin
 if FAlwaysShowCaret <> Value then begin
  FAlwaysShowCaret := Value;
  Selection.ShowCaret;
 end;
end;

procedure TInfoMemo.SetBitmapped(const Value: Boolean);
begin
 FBitmapped := Value;
 if (not Value) and Assigned(DrawBmp) then begin
  DrawBmp.Free;
  DrawBmp := nil;
 end;
end;

procedure TInfoMemo.SetBorderStyle(const Value: TBorderStyle);
begin
 if FBorderStyle <> Value then begin
  FBorderStyle := Value;
  RecreateWnd;
 end;
end;

procedure TInfoMemo.SetLeftMargin(const Value: Integer);
begin
 FLeftMargin := Value;
end;

procedure TInfoMemo.SetLines(const Value: TStrings);
begin
 FLines.Assign(Value);
end;

procedure TInfoMemo.SetReadOnly(const Value: Boolean);
var
i,LCount : Integer;
SMALines : TimAttributeLines;
begin
 if FReadOnly <> Value then begin
  FReadOnly := Value;
  Selection.ShowCaret;
 end;
 SMALines := TInfoMemoStrings(Lines).FAttributeLines;
 if FReadOnly then begin
  LCount := Lines.Count - SMALines.Count;
  if LCount <> 0 then begin
   if LCount < 0 then
    for i := LCount - 1 to 0 do SMALines.Delete(Lines.Count)
   else
    for i := 0 to LCount - 1 do SMALines.Add;
  end;
 end else begin
  SMALines.Clear;
 end;
end;

procedure TInfoMemo.SetScrollBars(const Value: TScrollStyle);
begin
 if FScrollBars <> Value then begin
  FScrollBars := Value;
  RecreateWnd;
 end;
end;

procedure TInfoMemo.SetSelLength(const Value: Integer);
begin
 Selection.RLength := Value;
end;

procedure TInfoMemo.SetSelStart(const Value: Integer);
begin
 Selection.NoSelAtPos(Value + 1);
end;

procedure TInfoMemo.SetTabSize(const Value: Integer);
var
 I: Integer;
begin
 if FTabSize <> Value then begin
  FTabSize := Value;
  if FTabSize < 1 then
   FTabSize := 1;
  Selection.DoChanging;
  FLongestLineLength := 0;
  for I := 0 to LineCount - 1 do
   if FLongestLineLength < VisualLineLength[I] then
    FLongestLineLength := VisualLineLength[I];
  VisibleRange.Update;
  Selection.DoChange;
 end;
end;

procedure TInfoMemo.SetText(const Value: TCaption);
begin
 WholeText.Text := Value;
end;

procedure TInfoMemo.SetTopMargin(const Value: Integer);
begin
 FTopMargin := Value;
end;

function TInfoMemo.TabSpacesAtPos(P: Integer): Integer;
var
 I: Integer;
 RS: TimTextCell;
 Ps: Integer;
begin
 if TabSize <= 1 then
  Result := TabSize
 else begin
  RS := CharIdxToCell(P);
  RS.Col := 1;
  Ps := 0;
  for I := CellToCharIdx(RS) to P - 1 do begin
   if Text[I] = #9 then
    TabPosAdjust(Ps,TabSize)
   else
    Inc(Ps);
  end;
  Result := TabSize - Ps mod TabSize;
 end;
end;

function TInfoMemo.GetLineOffset(Row: Integer): Integer;
begin
 Result := CellToCharIdx(imTextCell(Row,1));
end;

function  TInfoMemo.GetTabCharSize(const S: string): Integer;
var
i : Integer;
begin
 Result := 0;
 for i := 1 to Length(S) do if S[i] = #$09 then inc(Result,TabSize);
end;

procedure TInfoMemo.TextChangeNotification(StartPos,OldLength,NewLength: Integer;
                                             const NewText: string; Before: Boolean);
begin
 //
end;

procedure TInfoMemo.Undo;
begin
 Perform(em_Undo, 0, 0);
end;

procedure TInfoMemo.UpdateDrawBmp;
begin
 if Bitmapped then begin
  if not Assigned(DrawBmp) then
   DrawBmp := TBitmap.Create;
  if (DrawBmp.Width <> ClientWidth) or (DrawBmp.Height <> ClientHeight) then begin
   DrawBmp.Width := ClientWidth;
   DrawBmp.Height := ClientHeight;
   DrawBorder(Rect(0,0,LeftMargin,ClientHeight),Rect(0,0,ClientWidth,TopMargin),DrawBmp.Canvas);
  end;
 end else
  if Assigned(DrawBmp) then begin
   DrawBmp.Free;
   DrawBmp := nil;
  end;
end;

procedure TInfoMemo.UpdateFontSize;
begin
 if HandleAllocated and Assigned(Parent) then begin
  Canvas.Font.Assign(Font);
  FontHeight := Canvas.TextHeight('Q');
  FontWidth := Canvas.TextWidth('M');
  UpdatePageSize;
 end;
end;

procedure TInfoMemo.UpdatePageSize;
var
 ScrollInfo: TScrollInfo;
begin
 if HandleAllocated and Assigned(Parent) then begin
  UpdateDrawBmp;
  if FontHeight <= 0 then FontHeight := 13;
  if FontWidth <= 0 then FontWidth := 8;
  if HandleAllocated and Assigned(Parent) then begin
   PageHeight := (ClientHeight - TopMargin) div FontHeight;
   PageWidth := (ClientWidth