infomemo.pas

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

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

function TInfoMemo.GetLineCount: Integer;
begin
 Result := FLineStarts.Count;
end;

function TInfoMemo.GetLineLength(LineIndex: Integer): Integer;
begin
 Result := CellToCharIdx(imTextCell(LineIndex + 1,0)) -
           CellToCharIdx(imTextCell(LineIndex, 0)) - 2;
end;

function TInfoMemo.GetSelLength: Integer;
begin
 Result := Selection.RLength;
end;

function TInfoMemo.GetSelStart: Integer;
begin
 Result := Selection.RStart - 1;
end;

function TInfoMemo.GetVisualLineLength(LineIndex: Integer): Integer;
begin
 Result := CellToScrCol(imTextCell(LineIndex, GetLineLength(LineIndex) + 1)) - 1;
end;

function TInfoMemo.IsUndoBeginEndBlock(Op: PimUndoOperation): Boolean;
begin
 Result := Op.RStart = -1;
end;

procedure DBCCaretPositionUpDn(const S: string; var NewPos: Integer);
begin
 if not (S[NewPos] in [#10, #13]) then
  if (ByteType(S,NewPos) = mbTrailByte) then inc(NewPos);
end;

procedure DBCCaretPositionMove(const S: string; var NewPos: Integer; MaxLen: Integer;
                               ToLeft: Boolean);
var
NPos : Integer;
BType : TMbcsByteType;
begin
 if ToLeft then begin
  NPos := NewPos - 1;
  if NPos < 0 then Exit;
  BType := ByteType(S,NPos);
  if (BType = mbTrailByte) or (S[NPos] in [#10, #13]) then NewPos := NPos - 1
                                                      else NewPos := NPos;
 end else begin
  NPos := NewPos;
  if NPos > MaxLen then Exit;
  BType := ByteType(S,NPos);
  if (BType = mbLeadByte) or (S[NPos] in [#10, #13]) then NewPos := NPos + 2
                                                     else NewPos := NPos + 1;
 end;
end;

procedure DBCCaretPositionJump(const S: string; var NewPos: Integer; MaxLen: Integer;
                               ToLeft: Boolean);
var
InWord : Boolean;
begin
 if ToLeft then begin
  InWord := (NewPos > 1) and (NewPos < MaxLen) and (ByteType(S,NewPos - 1) = mbSingleByte);
  while (NewPos > 1) and ((ByteType(S,NewPos - 1) = mbSingleByte) = InWord) do begin
   if (S[NewPos - 1] in [#10, #13]) then Dec(NewPos, 2)
                                    else Dec(NewPos);
  end;
 end else begin
  InWord := (NewPos >= 1) and (NewPos <= MaxLen) and (ByteType(S,NewPos) = mbSingleByte);
  while (NewPos <= MaxLen) and ((ByteType(S,NewPos) = mbSingleByte) = InWord) do begin
   if S[NewPos] in [#10, #13] then Inc(NewPos, 2)
                              else Inc(NewPos);
  end;
 end;
end;

procedure TInfoMemo.KeyDown(var Key: Word; Shift: TShiftState);
var
LN : Integer;
NewPos: Integer;
Cell: TimTextCell;
SavScrCol: Integer;
begin
 inherited;
 FIsKeyChange := True;
 SavScrCol := -1;
 NewPos := Low(Integer);
 with Selection do begin
  case Key of
   vk_Clear  : if not ReadOnly then Clear;
   vk_Delete : if not ReadOnly then begin
                if Shift = [] then begin
                 if RLength = 0 then begin
                  DoChanging;
                  RLength := 1;
                  if RStart < TextLength - 1 then begin
                   if (ByteType(Self.Text,RStart) <> mbSingleByte) then
                    RLength := 2
                   else
                   if (RLength = 1) and (Text[1] in [#10, #13]) then
                    RLength := 2;
                  end;
                  DoDiscardChanges;
                 end;
                 Clear;
                end else
                if Shift = [ssShift] then CutToClipboard;
               end;
   vk_Insert : if ReadOnly then begin
                if Shift = [ssCtrl] then CopyToClipboard;
               end else begin
                if Shift = [ssShift] then
                 PasteFromClipboard
                else
                 if Shift = [ssCtrl] then CopyToClipboard;
               end;
   vk_Back   : if not ReadOnly then begin
                if Shift = [] then begin
                 if RLength = 0 then begin
                  DoChanging;
                  if RStart > 0 then begin
                   RStart := RStart - 1;
                   if (ByteType(Self.Text,RStart) <> mbSingleByte) then
                    RStart := RStart - 1
                   else
                   if(RLength = 1) and(Text[1] in [#10, #13]) then
                    RStart := RStart - 1;
                  end;
                  DoDiscardChanges;
                 end;
                 Clear;
                end else
                if Shift = [ssAlt] then
                 Undo
                else
                 if Shift = [ssAlt, ssShift] then Redo;
               end;
   vk_Left   : begin
                if (not (ssShift in Shift)) and
                   (RLength > 0) and
                   (not AlwaysShowCaret) then
                 REnd := RStart - 1
                else
                if (ssCtrl in Shift) then begin
                 NewPos := CursorPos;
                 DBCCaretPositionJump(Self.Text,NewPos,TextLength,True);
                end else begin
                 NewPos := CursorPos;
                 DBCCaretPositionMove(Self.Text,NewPos,TextLength,True)
                end;
               end;
   vk_Right  : begin
                if (not (ssShift in Shift)) and
                   (RLength > 0) and
                   (not AlwaysShowCaret) then
                 RStart := REnd + 1
                else
                if (ssCtrl in Shift) then begin
                 NewPos := CursorPos;
                 DBCCaretPositionJump(Self.Text,NewPos,TextLength,False);
                end else begin
                 NewPos := CursorPos;
                 DBCCaretPositionMove(Self.Text,NewPos,TextLength,False);
                end;
               end;
   vk_Up     : begin
                if (not (ssShift in Shift)) and
                   (RLength > 0) and
                   (not AlwaysShowCaret) then
                 REnd := RStart - 1
                else begin
                 SavScrCol := ScrCol;
                 Cell := CharIdxToCell(CursorPos);
                 Dec(Cell.Row);
                 LN := GetLineLength(Cell.Row);
                 if Cell.Col > LN then Cell.Col := LN + 1;
                 NewPos := CellToCharIdx(Cell);
                 DBCCaretPositionUpDn(Self.Text,NewPos);
                end;
               end;
   vk_Down   : begin
                if (not (ssShift in Shift)) and
                   (RLength > 0) and
                   (not AlwaysShowCaret) then
                 RStart := REnd + 1
                else begin
                 SavScrCol := ScrCol;
                 Cell := CharIdxToCell(CursorPos);
                 Inc(Cell.Row);
                 LN := GetLineLength(Cell.Row);
                 if Cell.Col > LN then Cell.Col := LN + 1;
                 NewPos := CellToCharIdx(Cell);
                 DBCCaretPositionUpDn(Self.Text,NewPos);
                end;
               end;
   vk_Prior  : begin // PageUp
                SavScrCol := ScrCol;
                Cell := CharIdxToCell(CursorPos);
                Dec(Cell.Row, PageHeight - 1);
                Cell.Col := ScrColToCol(Cell.Row);
                NewPos := CellToCharIdx(Cell);
                DBCCaretPositionUpDn(Self.Text,NewPos);
               end;
   vk_Next   : begin // PageDown
                SavScrCol := ScrCol;
                Cell := CharIdxToCell(CursorPos);
                Inc(Cell.Row, PageHeight - 1);
                Cell.Col := ScrColToCol(Cell.Row);
                NewPos := CellToCharIdx(Cell);
                DBCCaretPositionUpDn(Self.Text,NewPos);
               end;
   vk_Home   : begin
                Cell := CharIdxToCell(CursorPos);
                if ssCtrl in Shift then Cell.Row := 1;
                Cell.Col := 1;
                NewPos := CellToCharIdx(Cell);
               end;
   vk_End    : begin
                Cell := CharIdxToCell(CursorPos);
                if ssCtrl in Shift then Cell.Row := LineCount;
                Cell.Col := LineLength[Cell.Row] + 1;
                NewPos := CellToCharIdx(Cell);
               end;
  end;
  //
  if NewPos <> Low(Integer) then begin
   if ssShift in Shift then CursorPos := NewPos
                       else NoSelAtPos(NewPos);
   ScrCol := SavScrCol;
  end;
  ScrollInView(0);
 end;
 //
 if Shift = [ssCtrl] then begin
  case UpCase(Char(Key)) of
   'X': if not ReadOnly then CutToClipboard;
   'C': CopyToClipboard;
   'V': if not ReadOnly then PasteFromClipboard;
  end;
 end;
 //
 if (not ReadOnly) and (UpCase(Char(Key)) = 'Z') and (ssCtrl in Shift) then begin
   if ssShift in Shift then Redo
                       else Undo;
 end;
end;

procedure TInfoMemo.KeyPress(var Key: Char);
var
Cell: TimTextCell;
NewPos : Integer;
SavScrCol : Integer;
begin
 inherited;
 FIsKeyChange := True;
 if ReadOnly then begin
  if Key = #13 then Perform(WM_HSCROLL,SB_PAGELEFT,0);
  SavScrCol := Selection.ScrCol;
  Cell := CharIdxToCell(Selection.CursorPos);
  Inc(Cell.Row);
  Cell.Col := 1;
  NewPos := CellToCharIdx(Cell);
  if NewPos <> Low(Integer) then begin
   Selection.NoSelAtPos(NewPos);
   Selection.ScrCol := SavScrCol;
  end;
 end else begin
  if Key = #13 then begin
   Selection.Text := #13#10;
   Perform(WM_HSCROLL,SB_PAGELEFT,0);
  end else
  if (Key >= #32) or (Key = #9) then Selection.Text := Key;
 end;
end;

procedure TInfoMemo.MakeRedoOperation(Op: PimUndoOperation);
begin
 if Assigned(Op) then begin
  Op.NextItem := FRedoStack;
  FRedoStack := Op;
 end;
end;

procedure TInfoMemo.MakeUndoOperation(Op: PimUndoOperation);
begin
 if Assigned(Op) then begin
  Op.NextItem := FUndoStack;
  FUndoStack := Op;
 end;
end;

function TInfoMemo.ScrXToCol(X: Integer): Integer;
begin
 Result := (X + LeftMargin) div FontWidth;
end;

procedure TInfoMemo.SetInsLine(LineIndex,StringPos: Integer; const S: string);
begin
 TInfoMemoStrings(FLines).InsertStringToLine(LineIndex,StringPos,S);
end;

procedure TInfoMemo.SetRepLine(LineIndex,StringPos: Integer; const S: string);
begin
 TInfoMemoStrings(FLines).ReplaceStringToLine(LineIndex,StringPos,S);
end;

function TInfoMemo.GetLine(LineIndex,StringPos: Integer): string;
begin
 Result := TInfoMemoStrings(FLines).GetStringFromLine(LineIndex,StringPos);
end;

procedure TInfoMemo.MouseDown(Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
var
Cell : TimTextCell;
CurLine : Integer;
AStr : string;
begin
 inherited;
 try SetFocus except end;
 if (Button = mbLeft) or ((Button = mbRight) and (Selection.RLength <= 0)) then begin
  FSelStartPos.X := X;
  FSelStartPos.Y := Y;
  Cell := ScrPointToScrCell(Point(X,Y));
  Inc(Cell.Col,VisibleRange.LeftCol - 1);
  Inc(Cell.Row,VisibleRange.StartRowCol.Row - 1);
  CurLine := Cell.Row - 1;
  if (CurLine >= 0) and (CurLine < Lines.Count) then begin
   AStr := Lines.Strings[CurLine];
   if ByteType(AStr,Cell.Col) = mbTrailByte then inc(Cell.Col);
  end;
  CellFromScrCol(Cell);
  with TimMCRange.Create(nil) do begin
   Editor := Self;
   StartRowCol := Cell;
   Selection.NoSelAtPos(RStart);
   Free;
  end;
 end;
end;

procedure TInfoMemo.MouseMove(Shift: TShiftState; X, Y: Integer);
var
Cell: TimTextCell;
AStr : string;
CurLine : Integer;
begin
 inherited;
 if (csLButtonDown in ControlState) and
    ((Abs(X - FSelStartPos.X) >= FThreshold) or
     (Abs(Y - FSelStartPos.Y) >= FThreshold)) then begin
  //
  FOpenTimeCall := False;
  if X < 0 then begin
   X := 0;
   FOpenTimeCall := True;
   Perform(WM_HSCROLL,SB_LINELEFT,0);
  end else
  if X > ClientWidth then begin
   X := ClientWidth;
   FOpenTimeCall := True;
   Perform(WM_HSCROLL,SB_LINERIGHT,0);
  end;
  if Y < 0 then begin
   Y := 0;
   FOpenTimeCall := True;
   Perform(WM_VSCROLL,SB_LINEUP,0);
  end else
  if Y > ClientHeight then begin
   Y := ClientHeight;
   FOpenTimeCall := True;
   Perform(WM_VSCROLL,SB_LINEDOWN,0);
  end;
  //
  if HandleAllocated then begin
   if FOpenTimeCall then begin
    if not FTimeEnabled then begin
     SetTimer(Handle,1,30, nil);
     FTimeEnabled := True;
    end;
   end else begin
    if FTimeEnabled then begin
     KillTimer(Handle,1);
     FTimeEnabled := False;
    end;
   end;
  end;
  //
  Cell := ScrPointToScrCell(Point(X,Y));
  Inc(Cell.Row, VisibleRange.StartRowCol.Row - 1);
  Inc(Cell.Col, VisibleRange.LeftCol - 1);
  CurLine := Cell.Row - 1;
  if (CurLine >= 0) and (CurLine < Lines.Count) then begin
   AStr := Lines.Strings[CurLine];
   if ByteType(AStr,Cell.Col) = mbTrailByte then inc(Cell.Col);
  end;
  CellFromScrCol(Cell);
  with TimMCRange.Create(nil) do begin
   Editor := Self;
   StartRowCol := Cell;
   Selection.CursorPos := RStart;
   Free;
  end;
 end;
end;

procedure TInfoMemo.MouseUp(Button: TMouseButton; Shift: TShiftState;
                           X, Y: Integer);
begin
 inherited;
 if (Button in [mbLeft,mbRight]) then begin
  if HandleAllocated and FTimeEnabled then begin
   KillTimer(Handle,1);
   FTimeEnabled := False;
  end;
 end;
end;

procedure TInfoMemo.Paint;
begin
 Selection.HideCaret;
 if Bitmapped then begin