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

Question

需要从 TMemo 派生的组件(而不是 TSyn 组件)

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

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

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

对我来说，将组件分组在一起也不是解决方案，因为许多鼠标事件都与 Memo 相关联，并且对 FindVCLWindow 的调用将返回鼠标下更改的组件。此外，还需要许多组件，因此与 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;

你会得到这个结果

限制:

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

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

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

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

基本上是相同的想法。

<小时/>

编辑:

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

我还更改了获取组件 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
• How can I get a TEdit's canvas in Delphi? (Kobik's answer)