Question

需要一个来自TMemo的组件（不是TSyn组件）

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

我尝试通过将TShape与TMemo结合使用，用CustomContainersPack制作一些复合组件，甚至将TMemo叠加在TSynMemo上，但是由于拖拽时的绘画效果很差，所以拆装并没有成功，CCPack对于我的IDE不够强大

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

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

Answer 1

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

Answer 2

与其编写自定义控件，不如将面板或形状放在标准备注旁边，并为其提供所需的任何颜色。

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

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

现在，如果您想将文本，数字或图标放入排水沟中，则可以编写一个自定义控件。使用EM_SETRECT设置内部格式矩形，然后自定义覆盖Paint方法中的装订线。不要忘记致电inherited。

如何在TMemo的左侧绘制一条看起来像檐槽的彩色线

2 个答案: