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

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

我需要在TMemo的左侧（内部或外部）画一条线，其厚度（可选）和颜色可以控制，仅用于指示。它不需要作为一个排水沟，但看起来像一个特别像一个SynMemo，如图所示。SynMemo的问题在于它不支持Tahoma这样的可变宽度字体，但TMemo支持

我尝试用CustomContainerPack制作一些复合组件，将TShape与TMemo结合起来，甚至在TSynMemo上叠加一个TMemo，但没有成功，因为拖动时的绘制使它看起来被分解了，而CCPack对于我的IDE来说并没有那么健壮

KMemo、JvMemo和许多其他组件都已安装，并检查是否有任何隐藏的支持，以实现相同的目标，但都没有起作用

---

对我来说，将组件组合在一起也不是一个解决方案，因为许多鼠标事件都与备忘录相关联，对FindVCLWindow的调用将返回鼠标下更改的组件。此外，将需要许多组件，因此使用TPanel分组将提高内存使用率

您可以使用WM_Paint消息和hack来执行此操作，而无需创建新组件， 否则，创建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;

你得到了这个结果

限制：

由于这只是在侧面绘制一个简单矩形的另一个技巧，所以不要期望它在所有情况下都是完美的。在测试时，我确实注意到以下几点：

• 如果边界太厚，则会产生以下效果
• 当鼠标移动时，线有时会消失，并且不会被绘制（我认为这是因为绘制焦点矩形）

注意：我在评论中看到有人建议创建一个定制组件，将面板和备忘录放在一起，如果你想试试这个，请看我的答案

这基本上是相同的想法

---

编辑：

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

我还改变了获取组件画布的方式。新的实现就是这样

{ 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;

{TMemo}
程序TMemo.setaskforatention（常量值：布尔值）；
变量
FormatRect:TRect；
开始
如果是FaskForatention值，则
开始
faskforatention:=值；
如果不是时尚的话
开始
执行（EM_SETRECT，0，nil）；
结束
其他的
开始
FormatRect:=GetClientRect；
如果是右向左，那么
FormatRect.Right:=FormatRect.Right-FSideColorWidth-3
其他的
FormatRect.Left:=FormatRect.Left+FSideColorWidth+3；
执行（EM_SETRECT，0，FormatRect）；
结束；
使无效
结束；
结束；
程序TMemo.SetSideColor（常数值：TColor）；
开始
如果是FSideColor值，则
开始
FSideColor:=值；
使无效
结束；
结束；
程序TMemo.SetSideColorWidth（常量值：整数）；
变量
FormatRect:TRect；
开始
如果为FSideColorWidth值，则
开始
FSideColorWidth:=值；
FormatRect:=GetClientRect；
如果是右向左，那么
FormatRect.Right:=FormatRect.Right-FSideColorWidth-3
其他的
FormatRect.Left:=FormatRect.Left+FSideColorWidth+3；
执行（EM_SETRECT，0，FormatRect）；
结束；
结束；
程序TMemo.WMPaint（变量消息：TWMPaint）；
变量
画布：TControlCanvas；
正确：正确；
开始
继承；
如果Faskforatention那么
开始
画布：=TControlCanvas.Create；
尝试
Canvas.Control:=Self；
Canvas.Font.Assign（Self.Font）；
正确：=GetClientRect；
如果是右向左，那么
正确。左：=正确。右-FSideColorWidth
其他的
正确宽度：=FSideColorWidth；
Canvas.Brush.Color:=FSidecolor；
Canvas.Brush.Style:=bsSolid；
Canvas.FillRect（正确）；
最后
帆布。免费；
结束；
结束；
结束；

大小没有限制，也不会与滚动条重叠

最终结果：

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

• 控件TWinControl WM_绘制消息实现

---

不要编写自定义控件，而是在标准备忘旁边放置一个面板或形状，并给它任何你喜欢的颜色

如果这太单调而无法重复多次，那么将备忘录和形状放在一个框架上，并将其放入存储库中。设置锚定以确保其正确调整大小。你甚至不需要为此编写代码，你就有了一个即时的“模仿自定义控件”

比编写、安装和测试自定义控件更好、更简单

---

现在，如果你想把文本、数字或图标放在排水沟里，那么写一个自定义控件是值得的。使用

EM_SETRECT

设置内部格式矩形，并在替代的

Paint

方法中自定义绘制边沟。不要忘记调用

继承的

很少修改-此组件确实支持true type字体，但仅支持固定宽度字体（如

Courier

，

Console

等）。此外，您可以使用EM_SETRECT或其他EM_消息之一设置格式矩形。只需在左侧留出一些空间，然后在此处自定义绘制排水沟……以便于指示。具体说明了什么？@user30478：我不是建议你改变SynMemo，只是解释了为什么它会在那里工作。但请看我的其他评论。不是答案，因为我没有时间写东西，而是一个建议。只需重写Paint函数，调用inherited并添加您自己的行为。如果我是您，我可能会创建一个新的自定义控件，其中包含一个

TMemo

作为子控件，并在其左侧绘制一个条。编辑控件不能有边框，您可以自己绘制