infomemo.pas

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

           ReadOnlys[FReadOnly] or CharCases[FCharCase] or
           HideSelections[FHideSelection] or OEMConverts[FOEMConvert];
  if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then begin
   Style := Style and not WS_BORDER;
   ExStyle := ExStyle or WS_EX_CLIENTEDGE;
  end;
 end;
end;

function TInfoMemo.CreateSplitRanges(Range: TimCustomRange): TimFormattedRangeArray;
var
RS,RE : Integer;
begin
 RS := Range.RStart;
 if (not Selection.Hidden) and (Selection.RLength > 0) then begin
  // 选择区前
  RE := Selection.RStart - 1;
  if RE > Range.REnd then RE := Range.REnd;
  if RE >= RS then begin
   SetLength(Result,Length(Result) + 1);
   Result[High(Result)] := TimNormalFormattedRange.Create(nil);
   Result[High(Result)].FormattedRangeType := frtNormal;
   with Result[High(Result)] do begin
    FreeWhenDone := True;
    Editor := Self;
    RStart := RS;
    REnd := RE;
   end;
  end;
  // 选择区
  RS := Selection.RStart;
  if RS < Range.RStart then RS := Range.RStart;
  RE := Selection.REnd;
  if RE > Range.REnd then RE := Range.REnd;
  if RE >= RS then begin
   SetLength(Result,Length(Result) + 1);
   Result[High(Result)] := TimFormattedRange.Create(nil);
   Result[High(Result)].FormattedRangeType := frtSelect;
   with Result[High(Result)] do begin
    FreeWhenDone := True;
    Editor := Self;
    RStart := RS;
    REnd := RE;
    Color := clHighlight;
    Font.Assign(Self.Font);
    Font.Color := clHighlightText;
   end;
  end;
  RS := Selection.REnd + 1;
  if RS < Range.RStart then RS := Range.RStart;
 end;
 // 选择区后
 RE := Range.REnd;
 if RE >= RS then begin
  SetLength(Result, Length(Result) + 1);
  Result[High(Result)] := TimNormalFormattedRange.Create(nil);
  Result[High(Result)].FormattedRangeType := frtNormal;
  with Result[High(Result)] do begin
   FreeWhenDone := True;
   Editor := Self;
   RStart := RS;
   REnd := RE;
  end;
 end;
end;

function TInfoMemo.CreateUndoBeginEndBlock: PimUndoOperation;
begin
 New(Result);
 with Result^ do begin
  RStart := -1;
  REnd := -1;
  NewText := '';
 end;
end;

procedure TInfoMemo.CreateWnd;
var
AHCursor : THandle;
begin
 inherited;
 UpdateFontSize;
 if HandleAllocated and not (csDesigning in ComponentState) then begin
  AHCursor := LoadCursor(0,idc_IBeam);
  SetClassLong(Handle,GCL_HCURSOR,AHCursor);
 end;
end;

procedure TInfoMemo.CutToClipboard;
begin
 Perform(wm_Cut, 0, 0);
end;

destructor TInfoMemo.Destroy;
begin
 FSelection.Free;
 FVisibleRange.Free;
 FLines.Free;
 FTrackedRanges.Free;
 FWholeText.Free;
 FLineStarts.Free;
 if Assigned(DrawBmp) then begin
  DrawBmp.Free;
  DrawBmp := nil;
 end;
 FreeUndoRedoBuffer;
 inherited;
end;

procedure TInfoMemo.DrawBorder(LeftRect, TopRect: TRect; Canvas: TCanvas);
begin
 Canvas.Brush.Color := Color;
 Canvas.FillRect(LeftRect);
 Canvas.FillRect(TopRect);
end;

procedure TInfoMemo.DrawTextLine(Range: TimCustomRange; Left, Top: Integer; NextTabStop: Integer);
var
I : Integer;
R : TRect;
AR : TRect;
Cnv : TCanvas;
DLine : Integer;
StandardDraw : Boolean;
Ranges : TimFormattedRangeArray;
SMAList : TimAttributeList;
SMALines : TimAttributeLines;
begin
 if HandleAllocated and ((Range.RLength > 0) or (Range.REnd >= TextLength)) then begin
  if Bitmapped then Cnv := DrawBmp.Canvas
               else Cnv := Canvas;
  SetLength(Ranges,0);
  Ranges := CreateSplitRanges(Range);
  R := Rect(Left,Top,Left,Top + FontHeight);
  for I := Low(Ranges) to High(Ranges) do begin
   with Ranges[I] do begin
    if RLength > 0 then begin
     if (ByteType(Self.Text,RStart) = mbTrailByte) and (RStart - 1 >= 0) then begin
      RStart := RStart - 1;
      R.Left := R.Left - FontWidth;
     end;
     if (ByteType(Self.Text,REnd) = mbLeadByte) and (REnd + 1 < TextLength) then begin
      REnd := REnd + 1;
      R.Right := R.Right + FontWidth;
     end;
     //
     DLine := Range.StartRowCol.Row - 1;
     StandardDraw := True;
     //
     if FormattedRangeType = frtNormal then begin
      SMALines := TInfoMemoStrings(Lines).AttributeLines;
      if Assigned(SMALines) and (DLine >= 0) and (DLine < SMALines.Count) then begin
       SMAList := SMALines.Items[DLine];
       if SMAList <> nil then StandardDraw := False;
      end;
     end;
     //
     if not StandardDraw then begin
      AR := R;
      StandardDrawTo(Ranges[I],R,NextTabStop);
      if FReadOnly then AttributeDrawTo(Ranges[I],AR,NextTabStop);
     end else StandardDrawTo(Ranges[I],R,NextTabStop);
     //
     R.Left := R.Right;
    end;
    if FreeWhenDone then Free;
   end;
  end;
  if Range.REnd >= TextLength then begin
   if R.Left < LeftMargin then R.Left := LeftMargin;
   R.Right := ClientWidth;
   Cnv.Brush.Color := Color;
   Cnv.FillRect(R);
  end;
 end;
end;

procedure TInfoMemo.AttributeDrawTo(Range : TimCustomFormattedRange; var R: TRect; NextTabStop: Integer);
var
i : Integer;
Cnv : TCanvas;
DrawOK : Boolean;
AttrStr : string;
RangeStr : string;
SMAList : TimAttributeList;
SMAData : PimAttributeData;
SMALines : TimAttributeLines;
DrawWidth : Integer;
RangeStrLen : Integer;
OrgX : Integer;
FR : TRect;
LIndex,LOffset : Integer;
LF,LL,SP,X,TextFlags : Integer;
begin
 LIndex := Range.StartRowCol.Row - 1;
 SMALines := TInfoMemoStrings(Lines).AttributeLines;
 if (not Assigned(SMALines)) or (LIndex < 0) and (LIndex >= SMALines.Count) then Exit;
 SMAList := SMALines.Items[LIndex];
 if SMAList = nil then Exit;
 //
 if Bitmapped then begin
  Cnv := DrawBmp.Canvas;
  TextFlags := eto_Opaque or eto_Clipped;
 end else begin
  Cnv := Canvas;
  TextFlags := eto_Opaque or eto_Clipped;
 end;
 //
 with Range do begin
  if Self.Text[REnd] = #10 then
   RangeStr := Copy(Self.Text,RStart,RLength - 2)
  else
  if Self.Text[REnd] = #13 then
   RangeStr := Copy(Self.Text,RStart,RLength - 1)
  else
   RangeStr := Copy(Self.Text,RStart,RLength);
  //
  SP := 1;
  while SP <= Length(RangeStr) do begin
   if RangeStr[SP] = #9 then begin
    System.Delete(RangeStr,SP,1);
    System.Insert(StringOfChar(' ',NextTabStop),RangeStr,SP);
    Inc(SP,NextTabStop);
   end else Inc(SP);
  end;
  RangeStrLen := Length(RangeStr);
  //
  if (REnd <= TextLength) and (Self.Text[REnd] in [#10, #13]) then
   R.Right := ClientWidth
  else
   R.Right := R.Left + FontWidth * RangeStrLen;
  //
  OrgX := R.Left;
  FR := R;
  FR.Right := LeftMargin;
  FR.Left := 0;
  if R.Left < LeftMargin then R.Left := LeftMargin;
  if R.Right > R.Left then begin
   DrawOK := False;
   LOffset := StartRowCol.Col - 1;
   for i := 0 to SMAList.Count - 1 do begin
    SMAData := SMAList.Items[i];
    LF := SMAData^.First - LOffset;
    LL := SMAData^.Last - LOffset;
    if LL < 1 then Continue;
    if LF < 1 then LF := 1;
    if LF > LL then Continue;
    if LL >= RangeStrLen then begin
     LL := RangeStrLen;
     DrawOK := True;
    end;
    //
    AttrStr := Copy(RangeStr,LF,LL - LF + 1);
    DrawWidth := Length(AttrStr) * FontWidth;
    dec(LF);
    //
    X := OrgX + LF * FontWidth;
    R.Left  := X;
    R.Right := X + DrawWidth;
    //
    Cnv.Font.Assign(Font);
    if FUseVolatileColor then begin
     Cnv.Font.Color := FVolatileForeColor;
     Cnv.Brush.Color := FVolatileBackColor;
    end else begin
     Cnv.Font.Style := SMAData.FontStyles;
     Cnv.Font.Color := SMAData.ForeColor;
     Cnv.Brush.Color := SMAData.FontStylesBackColor and $00FFFFFF;
    end;
    ExtTextOut(Cnv.Handle,X,R.Top,TextFlags,@R,PChar(AttrStr),Length(AttrStr),nil);
    if DrawOK then Break;
   end;
   Cnv.Brush.Color := Color;
   Cnv.FillRect(FR);
  end;
 end;
end;

procedure TInfoMemo.StandardDrawTo(Range : TimCustomFormattedRange; var R: TRect; NextTabStop: Integer);
var
S : string;
SP,X,Y,TextFlags : Integer;
Cnv : TCanvas;
begin
 if Bitmapped then begin
  Cnv := DrawBmp.Canvas;
  TextFlags := eto_Opaque or eto_Clipped;
 end else begin
  Cnv := Canvas;
  TextFlags := eto_Opaque or eto_Clipped;
 end;
 with Range do begin
  Cnv.Brush.Color := Color;
  Cnv.Font.Assign(Font);
  //
  if Self.Text[REnd] = #10 then
   S := Copy(Self.Text,RStart,RLength - 2)
  else
  if Self.Text[REnd] = #13 then
   S := Copy(Self.Text,RStart,RLength - 1)
  else
   S := Copy(Self.Text, RStart, RLength);
  //
  SP := 1;
  while SP <= Length(S) do begin
   if S[SP] = #9 then begin
    System.Delete(S,SP,1);
    System.Insert(StringOfChar(' ',NextTabStop),S,SP);
    Inc(SP,NextTabStop);
   end else Inc(SP);
  end;
  //
  if (REnd <= TextLength) and (Self.Text[REnd] in [#10, #13]) then begin
   R.Right := ClientWidth;
  end else
   R.Right := R.Left + FontWidth * Length(S);
  //
  X := R.Left;
  Y := R.Top;
  if R.Left < LeftMargin then R.Left := LeftMargin;
  if R.Right > R.Left then begin
   if FUseVolatileColor then begin
    Cnv.Font.Color := FVolatileForeColor;
    Cnv.Brush.Color := FVolatileBackColor;
   end;
   ExtTextOut(Cnv.Handle,X,Y,TextFlags,@R,PChar(S),Length(S),nil);
  end;
 end;
end;

procedure TInfoMemo.EMCanUndo(var Message: TMessage);
begin
 if Message.WParam = 1 then Message.Result := Integer(Assigned(FRedoStack))
                       else Message.Result := Integer(Assigned(FUndoStack));
end;

procedure TInfoMemo.EMUndo(var Message: TMessage);
var
 Op: TimUndoOperation;
 NewOp: PimUndoOperation;
 Repeating: Boolean;
 CurSel: TimMCRange;
begin
 if Perform(em_CanUndo, Message.WParam, 0) <> 0 then
  with Message do begin
   FInUndo := True;
   Repeating := False;
   CurSel := nil;
   repeat
    if WParam = 1 then
     Op := GetLastRedo
    else
     Op := GetLastUndo;
    if IsUndoBeginEndBlock(@Op) then begin
     Repeating := not Repeating;
     if Repeating then begin
      DontNotify := True;
      VisibleRange.DoChanging;
     end else begin
      VisibleRange.DoDiscardChanges;
      Selection.HideCaret;
      VisibleRange.DrawRange;
      if Assigned(CurSel) then
       Selection.Assign(CurSel);
      Selection.UpdateCaretPos;
      Selection.ShowCaret;
      DontNotify := False;
      Self.Change;
      SelectionChange;
     end;
     if WParam = 1 then
      MakeUndoOperation(CreateUndoBeginEndBlock)
     else
      MakeRedoOperation(CreateUndoBeginEndBlock);
    end else begin
     with TimMCRange.Create(nil) do begin
      Editor := Self;
      New(NewOp);
      RStart := Op.RStart;
      REnd := Op.REnd;
      NewOp.NewText := Text;
      Text := Op.NewText;
      NewOp.RStart := RStart;
      NewOp.REnd := REnd;
      if WParam = 1 then
       MakeUndoOperation(NewOp)
      else
       MakeRedoOperation(NewOp);
      if Repeating then begin
       if Assigned(CurSel) then begin
        if REnd + 1 > CurSel.RStart then
         CurSel.RStart := REnd + 1;
       end else begin
        CurSel := TimMCRange.Create(TrackedRanges);
        CurSel.RStart := REnd + 1;
       end;
      end else AssignTo(Selection);
      Free;
     end;
    end;
   until not Repeating;
   if Assigned(CurSel) then CurSel.Free;
   FInUndo := False;
   Change;
  end;
end;

procedure TInfoMemo.FreeCaret;
begin
 if FCaretCreated then begin
  Selection.HideCaret;
  DestroyCaret;
  FCaretCreated := False;
 end;
end;

function TInfoMemo.GetCanRedo: Boolean;
begin
 Result := Perform(em_CanUndo,1,0) <> 0;
end;

function TInfoMemo.GetCanUndo: Boolean;
begin
 Result := Perform(em_CanUndo,0,0) <> 0;
end;

function TInfoMemo.GetLastRedo: TimUndoOperation;
begin
 if Assigned(FRedoStack) then begin
  Result := FRedoStack^;
  Dispose(FRedoStack);
  FRedoStack := Result.NextItem;
 end;
end;