delphi - 如何在TMemo的左侧绘制一条看起来像排水沟的彩色线

需要一个从TMemo派生的组件（不是TSyn组件）

我需要在TMemo的左侧（内部或外部）放置一条线，其厚度（可选）和颜色可以仅出于指示目的而进行控制。它不必充当装订线的功能，而是看起来特别像SynMemo那样，如图所示。 SynMemo的问题在于它不支持Tahoma这样的可变宽度字体，而TMemo却支持。



我尝试通过将TShape与TMemo结合使用，甚至通过将TMemo叠加在TSynMemo之上，使用CustomContainersPack制作一些复合组件，但是由于拖拽时的绘画效果使得它看起来很可拆卸，CCPack对于我的IDE并不那么健壮。

安装了KMemo，JvMemo和许多其他Torry.net组件，并检查了是否有隐藏的支持来实现相同的功能，但没有任何功能。

对于我来说，将组件分组到一起并不是一个解决方案，因为许多鼠标事件与备忘录相关，并且对FindVCLWindow的调用将返回鼠标下更改的组件。此外，将需要许多组件，因此与TPanel分组会增加内存使用量。

最佳答案

您可以使用WM_Paint消息和黑客来执行此操作，而无需创建新组件，
否则，创建TMemo的后代并在下面应用相同的更改

 TMemo = class(Vcl.StdCtrls.TMemo)
  private
    FSidecolor: TColor;
    FSideColorWidth: Integer;
    FAskForAttention: Boolean;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure SetSideColorWidth(const Value: Integer);
    procedure SetSideColor(const Value: TColor);
    procedure SetAskForAttention(const Value: Boolean);
  published
    property SideColor: TColor read FSideColor write SetSideColor default clRed;
    property SideColorWidth: Integer read FSideColorWidth write SetSideColorWidth default 2;
    property AskForAttension: Boolean read FAskForAttention write SetAskForAttention;
  end;

{ TMemo }

procedure TMemo.SetAskForAttention(const Value: Boolean);
begin
  FAskForAttention := Value;
  Invalidate;
end;

procedure TMemo.SetSideColor(const Value: TColor);
begin
  FSideColor := Value;
  Invalidate;
end;

procedure TMemo.SetSideColorWidth(const Value: Integer);
begin
  FSideColorWidth := Value;
  Invalidate;
end;

procedure TMemo.WMPaint(var Message: TWMPaint);
var
  DC: HDC;
  Pen: HPen;
  R,G,B: Byte;
begin
  inherited;
  if FAskForAttention then
  begin
    DC := GetWindowDC(Handle);
    try
      B := Byte(FSidecolor);
      G := Byte(FSidecolor shr 8);
      R := Byte(FSidecolor shr 16);

      Pen := CreatePen(PS_SOLID, FSideColorWidth, RGB(R,G,B));
      SelectObject(DC, Pen);
      SetBkColor(DC, RGB(R,G,B));
      Rectangle(DC, 1, 1, FSideColorWidth, Height - 1);
      DeleteObject(Pen);
    finally
      ReleaseDC(Handle, DC);
    end;
  end;
end;

你可以这样使用它

procedure TForm15.Button1Click(Sender: TObject);
begin
  memo1.SideColor := ColorBox1.Selected;
  memo1.SideColorWidth := 2;
  memo1.AskForAttension := True;
end;

你得到这个结果



局限性：

由于这只是在侧面绘制简单矩形的另一招，因此不要指望它在所有情况下都是完美的。我在测试时确实注意到以下内容：


如果边框太粗，您将获得以下效果

用鼠标移动时，线条有时会消失并且不会被绘制（我认为这是由于绘制焦点矩形而引起的）。


注意：我看到有人建议创建面板和便笺放在一起的自定义组件，如果您想尝试此操作，请查看我的回答。

Creating a new components by combining two controls (TEdit and TTrackBar) in Delphi VCL

这基本上是相同的想法。



编辑：

好吧，我考虑了评论中提到的内容并修改了答案，

我还更改了获取组件画布的方式。新的实施变成这个

{ TMemo }

procedure TMemo.SetAskForAttention(const Value: Boolean);
var
  FormatRect: TRect;
begin
  if FAskForAttention <> Value then
  begin
    FAskForAttention := Value;

    if not FAskForAttention then
    begin
      Perform(EM_SETRECT, 0, nil);
    end
    else
    begin
      FormatRect := GetClientRect;

      if IsRightToLeft then
        FormatRect.Right := FormatRect.Right - FSideColorWidth - 3
      else
        FormatRect.Left := FormatRect.Left + FSideColorWidth + 3;

      Perform(EM_SETRECT, 0, FormatRect);
    end;
    Invalidate;
  end;
end;

procedure TMemo.SetSideColor(const Value: TColor);
begin
  if FSideColor <> Value then
  begin
    FSideColor := Value;
    Invalidate;
  end;
end;

procedure TMemo.SetSideColorWidth(const Value: Integer);
var
  FormatRect: TRect;
begin
  if FSideColorWidth <> Value then
  begin
    FSideColorWidth := Value;
    FormatRect := GetClientRect;

    if IsRightToLeft then
      FormatRect.Right := FormatRect.Right - FSideColorWidth - 3
    else
      FormatRect.Left := FormatRect.Left + FSideColorWidth + 3;

    Perform(EM_SETRECT, 0, FormatRect);
  end;
end;

procedure TMemo.WMPaint(var Message: TWMPaint);
var
  Canvas: TControlCanvas;
  CRect: TRect;
begin
  inherited;
  if FAskForAttention then
  begin
    Canvas := TControlCanvas.Create;
    try
      Canvas.Control := Self;
      Canvas.Font.Assign(Self.Font);

      CRect := GetClientRect;

      if IsRightToLeft then
        CRect.Left := CRect.Right - FSideColorWidth
      else
        CRect.Width := FSideColorWidth;

      Canvas.Brush.Color := FSidecolor;
      Canvas.Brush.Style := bsSolid;
      Canvas.FillRect(CRect);
    finally
      Canvas.Free;
    end;
  end;
end;

大小没有限制，并且不与滚动条重叠。

最后结果：



我以前写这个答案的参考文献：


MSDN Painting and Drawing Functions
MSDN Using the WM_PAINT Message
Creating Colored Pens and Brushes example
Vcl.Controls TWinControl WM_Paint消息实现
EM_SETRECT message
How can I get a TEdit's canvas in Delphi? (Kobik's answer)