mwcustomedit.pas

完全不使用 Windows 标准 Edit Control 而实作出的改良版 TEdit 构件

      begin
        TopLine := fLines.Count;
        CaretY := fLines.Count;
      end;
    VK_HOME:
      begin
        TopLine := 0;
        CaretY := 1;
      end;
    VK_LEFT:
      begin
        CaretX := CaretX - 1;
        if CaretX < LeftChar then LeftChar := LeftChar - 1;
      end;
    VK_RIGHT:
      begin
        CaretX := CaretX + 1;
        if CaretX >= LeftChar + GetCharsInWindow then LeftChar := LeftChar + 1;
      end;
  end;
end;

procedure TmCustomEdit.KeyPress(var Key: Char);
begin
  inherited;
end;

procedure TmCustomEdit.SetCaretPosition(X, Y: Integer);
begin
  if X < 1 then X := 1;
  fCaretX := X - 1;
  if Y < 1 then Y := 1;
  if Y > fLines.Count then Y := fLines.Count;
  fCaretY := Y - 1;
  UpdateCaret;
end;

procedure TmCustomEdit.ComputeCaret(X, Y: Integer);
var
  TempX, TempY, CW, TH: Integer;
begin
  CW := GetCharWidth;
  TH := GetTextHeight;
  TempX := (X + fLeftChar * CW - FGutterWidth + BlancOffset) div CW;
  TempY := (Y - BlancOffset) div TH + TopLine;
  SetCaretPosition(TempX, TempY);
end;

procedure TmCustomEdit.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  Try
    SetFocus;
  finally
    MouseCapture := True;
  End;
  ComputeCaret(X, Y);
  UpdateCaret;
end;

procedure TmCustomEdit.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseMove(Shift, x, y);
end;

procedure TmCustomEdit.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  if (GetCapture <> 0) then
    MouseCapture := False;
end;

procedure TmCustomEdit.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
end;

procedure TmCustomEdit.PaintText;
var
  I, J, H: Integer;
  aOffset: Integer;
begin
  aOffset := BlancOffset;
  H := GetTextHeight;
  J := fTopLine;
  for I := 0 To GetLinesInWindow - 1 do
  begin
    Case J < fLines.Count of
      True: TextBM.Canvas.TextOut(Offset, (I * H + aOffset), fLines[J]);
    end;
    inc(J);
  end;
end;

procedure TmCustomEdit.PaintGutter;
var
  aPoint: TPoint;
  aOffset: Integer;
begin
  with TextBM.Canvas do
  begin
    aOffset := GetBlancOffset - 2;
    Pen.Color := clBtnFace;
    Pen.Width := GutterWidth * 2 + aOffset;
    aPoint.X := aOffset;
    aPoint.Y := 0;
    PenPos := aPoint;
    aPoint.Y := ToCopy.Bottom;
    LineTo(aPoint.X, aPoint.Y);

    Pen.Color := clBtnHighlight;
    Pen.Width := 1;
    aPoint.X := aOffset + fGutterWidth - 3;
    aPoint.Y := 0;
    PenPos := aPoint;
    aPoint.Y := ToCopy.Bottom;
    LineTo(aPoint.X, aPoint.Y);

    Pen.Color := clBtnShadow;
    Pen.Width := 1;
    aPoint.X := aOffset + fGutterWidth - 2;
    aPoint.Y := 0;
    PenPos := aPoint;
    aPoint.Y := ToCopy.Bottom;
    LineTo(aPoint.X, aPoint.Y);

    Pen.Color := Color;
    Pen.Width := 3;
    aPoint.X := aOffset + fGutterWidth;
    aPoint.Y := 0;
    PenPos := aPoint;
    aPoint.Y := ToCopy.Bottom;
    LineTo(aPoint.X, aPoint.Y);
  end;
end;

procedure TmCustomEdit.PaintControl;
var
  H: Integer;
  Color1, Color2: TColor;
  aPoint: TPoint;

  procedure PaintBlueLine;
  begin
    with TextBM.Canvas do
    begin
      Pen.Color := clTeal;
      Pen.Width := 1;
      aPoint.X := Offset + GetCharWidth * 80;
      aPoint.Y := 0;
      PenPos := aPoint;
      aPoint.Y := ToCopy.Bottom;
      LineTo(aPoint.X, aPoint.Y);
    end;
  end;

  procedure PaintFrame(const R: TRect);
  begin
    with TextBM.Canvas do
    begin
      Pen.Width := 1;
      Pen.Color := clBtnShadow;
      PolyLine([Point(R.Left, R.Bottom - 2), Point(R.Left, R.Top),
        Point(R.Right, R.Top)]);
      Pen.Color := clBlack;
      PolyLine([Point(R.Left + 1, R.Bottom - 2), Point(R.Left + 1, R.Top + 1),
        Point(R.Right, R.Top + 1)]);
      Pen.Color := Color2;
      PolyLine([Point(R.Right - 1, R.Top), Point(R.Right - 1, R.Bottom - 1),
        Point(R.Left, R.Bottom - 1)]);
      Pen.Color := clBtnFace;
      PolyLine([Point(R.Right - 2, R.Top), Point(R.Right - 2, R.Bottom - 2),
        Point(R.Left, R.Bottom - 2)]);
    end;
  end;

begin
  try
    Font.Pitch := fpFixed;
    TextBM := TBitmap.Create;
    TextBM.Canvas.Font.Assign(Font);
    Canvas.Font.Assign(Font);
    TextBM.Height := Height;
    TextBM.Width := Width;
    Color1 := clBlack;
    Color2 := clBtnHighlight;
    TextBM.Canvas.Brush.Color := Color;
    TextBM.Canvas.FillRect(TextBM.Canvas.ClipRect);
    if fLines.Count = 0 then exit;
    PaintText;
    PaintGutter;
    if Ctl3D then
    begin
      PaintFrame(ToCopy);
    end;
    Canvas.CopyRect(ToCopy, TextBM.Canvas, ToCopy);
  finally
    TextBM.Free;
  end;
end;

procedure TmCustomEdit.Paint;
begin
  inherited;
  HideCaret;
  PaintControl;
  UpdateCaret;
end;

procedure TmCustomEdit.PasteFromClipboard;
begin

end;

procedure TmCustomEdit.SelectAll;
begin

end;

function TmCustomEdit.GetCaretX: Integer;
begin
  Result := fCaretX + 1;
end;

function TmCustomEdit.CaretXPix: Integer;
var
  CW: Integer;
begin
  CW := GetCharWidth;
  fCaretXPix := fGutterWidth + BlancOffSet + fCaretX * CW - fLeftChar * CW;
  Result := fCaretXPix;
end;

procedure TmCustomEdit.SetCaretX(Value: Integer);
begin
  if Value < 1 then Value := 1;
  fCaretX := Value - 1;
  UpdateCaret;
end;

function TmCustomEdit.GetCaretY: Integer;
begin
  Result := fCaretY + 1;
end;

function TmCustomEdit.CaretYPix: Integer;
var
  TH: Integer;
begin
  TH := GetTextHeight;
  fCaretYPix := BlancOffSet + 2 + fCaretY * TH - fTopLine * TH;
  Result := fCaretYPix;
end;

procedure TmCustomEdit.SetCaretY(Value: Integer);
begin
  if Value < 1 then Value := 1;
  if Value > fLines.Count then Value := fLines.Count;
  fCaretY := Value - 1;
  UpdateCaret;
end;

procedure TmCustomEdit.SetFont(const Value: TFont);
begin
  Value.Pitch := fpFixed;
  inherited Font := Value;
end;

procedure TmCustomEdit.SetLineText(const Value: String);
begin

end;

procedure TmCustomEdit.SetSelLength(Value: Integer);
begin

end;

procedure TmCustomEdit.SetSelStart(Value: Integer);
begin

end;

procedure TmCustomEdit.SetSelText(Value: String);
begin

end;

procedure TmCustomEdit.SetText(Value: String);
begin

end;

procedure TmCustomEdit.SetTopLine(Value: Integer);
begin
  if Value > fLines.Count then Value := fLines.Count;
  if Value < 1 then Value := 1;
  fTopLine := Value - 1;
  Paint;
end;

procedure TmCustomEdit.ShowCaret;
begin
  if Windows.ShowCaret(Handle) then fCaretVisible := True;
end;

procedure TmCustomEdit.Undo;
begin

end;

procedure TmCustomEdit.UpdateCaret;
var
  CX, CY: Integer;
begin
  CX := CaretXPix;
  CY := CaretYPix;
  SetCaretPos(CX, CY);
  ShowCaret;
  if (CX <= GutterWidth) or (CX >= Width - BlancOffset) or
    (CY <= BlancOffset) or (CY >= Height - GetTextHeight) then
    HideCaret;
end;

procedure TmCustomEdit.UpdatePaint;
begin

end;

procedure TmCustomEdit.WMClear(var Msg: TMessage);
begin
  inherited;
end;

procedure TmCustomEdit.WMCopy(var Msg: TMessage);
begin
  inherited;
end;

procedure TmCustomEdit.WMCut(var Msg: TMessage);
begin
  inherited;
end;

procedure TmCustomEdit.WMEraseBkgnd(var Msg: TMessage);
begin
  inherited;
end;

procedure TmCustomEdit.WMGetDlgCode(var Msg: TWMGetDlgCode);
begin
  Msg.Result := DLGC_WANTARROWS;
  Msg.Result := Msg.Result or DLGC_WANTCHARS;
end;

procedure TmCustomEdit.WMMove(var Message: TWMMove);
begin
  inherited;
end;

procedure TmCustomEdit.WMPaste(var Msg: TMessage);
begin

end;

procedure TmCustomEdit.WMSize(var Message: TWMSize);
begin
  inherited;
end;

procedure TmCustomEdit.WMUndo(var Msg: TMessage);
begin

end;

function TmCustomEdit.GetLeftChar: Integer;
begin
  Result := fLeftChar + 1;
end;

procedure TmCustomEdit.SetLeftChar(Value: Integer);
begin
  if Value < 1 then Value := 1;
  fLeftChar := Value - 1;
  Paint;
end;

procedure TmCustomEdit.WMPaint(var Message: TWMPaint);
begin
  inherited;
end;

procedure TmCustomEdit.WMKillFocus(var Message: TWMSetFocus);
begin
  inherited;
  HideCaret;
  Windows.DestroyCaret;
end;

procedure TmCustomEdit.WMSetFocus(var Message: TWMSetFocus);
begin
  inherited;
  CreateCaret(Handle, 0, 2, GetTextHeight - 2);
  UpDateCaret;
end;

procedure TmCustomEdit.WMWindowPosChanged(
  var Message: TWMWindowPosChanged);
begin
  inherited;
  PaintControl;
end;

procedure TmCustomEdit.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  with ToCopy do
  begin
    Left := 0;
    Top := 0;
    Right := Width;
    Bottom := Height;
  end;
end;

end.