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

Question

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

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

我尝试通过将 TShape 与 TMemo 结合使用 CustomContainersPack 来制作一些复合组件，甚至将 TMemo 叠加在 TSynMemo 之上，但没有成功，因为拖动时的绘制使其看起来已拆解，而且 CCPack 不是那么健壮我的 IDE.

KMemo、JvMemo 和许多其他 Torry.net 组件已安装并检查是否有任何隐藏的支持以实现相同的目的，但 none 有效。

将组件组合在一起也不是我的解决方案，因为许多鼠标事件都与备忘录相关，并且调用 FindVCLWindow 将 return 更改鼠标下的组件。此外，将需要许多组件，因此使用 TPanel 进行分组将增加内存使用量。

Answer 1

您可以使用 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;

你得到这个结果

限制：

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

如果边框太粗你会得到以下效果
当鼠标移动时，线条有时会消失并且不会被绘制（我认为这是因为绘制焦点是矩形的）。

注意：我看到评论里的人建议创建一个自定义组件，面板和备忘录放在一起，如果你想试试这个，看看我的回答

思路基本相同

编辑：

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

我还更改了获取组件 canvas 的方式。新的实现变成了这个

{ 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

Answer 2

与其编写自定义控件，不如在标准备忘录旁边放置一个面板或形状，并为其赋予任何你喜欢的颜色。

如果这太乏味而无法重复多次，请将备忘录和形状放在一个框架上，然后将其放入存储库中。设置锚点以确保它们正确调整大小。您甚至不需要为此编写代码，您可以立即 "imitation custom control".

比编写、安装和测试自定义控件好得多、简单得多，IMO。

现在，如果您想在装订线中放置文本或数字或图标，那么编写自定义控件是值得的。使用 EM_SETRECT 设置内部格式矩形，并在覆盖的 Paint 方法中自定义绘制装订线。不要忘记调用 inherited。

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

How to draw a colored line to the left of a TMemo which looks like a gutter

delphi

delphi-xe5