delphi - 在窗口周围绘制框架时出现问题

Question

在 Windows 10 中的 Delphi 10.4.2 Win32 VCL 应用程序中，我尝试在窗口周围绘制一个框架（-control）：

procedure FrameWindow(aHandle: HWND);
var
  Rect: TRect;
  DC: Winapi.Windows.HDC;
  OldPen, Pen: Winapi.Windows.HPEN;
  OldBrush, Brush: Winapi.Windows.HBRUSH;
  X2, Y2: Integer;
begin
  { Get the target window's rect and DC }
  Winapi.Windows.GetWindowRect(aHandle, Rect);
  DC := Winapi.Windows.GetWindowDC(aHandle);
  { Set ROP appropriately for highlighting }
  Winapi.Windows.SetROP2(DC, R2_NOT);
  { Select brush and pen }
  Pen := Winapi.Windows.CreatePen(PS_InsideFrame, 3, 0);
  OldPen := Winapi.Windows.SelectObject(DC, Pen);
  Brush := Winapi.Windows.GetStockObject(Null_Brush);
  OldBrush := Winapi.Windows.SelectObject(DC, Brush);
  { Set dimensions of highlight }
  X2 := Rect.Right - Rect.Left;
  Y2 := Rect.Bottom - Rect.Top;
  { Draw highlight box }
  Rectangle(DC, 0, 0, X2, Y2);
  { Clean up }
  SelectObject(DC, OldBrush);
  SelectObject(DC, OldPen);
  ReleaseDC(aHandle, DC);
  { Do NOT delete the brush, because it was a stock object }
  DeleteObject(Pen);
end;

（当使用相同的窗口句柄第二次调用 FrameWindow 过程时，将删除该框架）。

这适用于窗口上的控件：

Target.WindowHandle当光标下的窗口句柄 ( ) 发生变化并且需要擦除旧框架时，会定期调用 FrameWindow 过程以绘制新框架：

{ To avoid flickering, remove the old frame ONLY if moved to a new window }
if Target.WindowHandle <> FOldWindowHandle then
begin
  if FOldWindowHandle <> 0 then
    FrameWindow(FOldWindowHandle); // remove the old frame
  if Target.WindowHandle <> 0 then
    FrameWindow(Target.WindowHandle); // create new frame
  FOldWindowHandle := Target.WindowHandle; // remember new frame
end;

问题 #1：这仅适用于窗口上的控件，而不适用于整个窗口（例如，当鼠标光标位于记事本的标题栏上时），尽管整个窗口的窗口句柄是正确的：周围没有绘制框架整个窗口。

问题 #2：有时帧已损坏：

问题#3：如何将框架颜色设置为红色而不是黑色？

如何解决这些问题？

标签： delphiwinapidelphi-10.4-sydney

Answer 1

我已经完全放弃了在桌面上画画的想法。现在我使用 TRANSPARENT CLICK-THROUGH 窗口并将其放置在目标窗口上：

Here is the source code of the form unit:

unit Unit1;

interface

uses
  Winapi.Windows, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  Win: HWND;
  R: TRect;
  offset: Integer;
begin
  Win := 135642;
  GetWindowRect(Win, R);
  offset := Panel2.Margins.Bottom;
  InflateRect(R, offset, offset);
  Self.BoundsRect := R;
  Self.Left := R.Left;
  Self.Top := R.Top;
end;

procedure TForm1.CreateParams(var Params: TCreateParams);
// https://stackoverflow.com/questions/11809973/click-through-transparent-form
begin
  inherited;
  Params.ExStyle := Params.ExStyle or WS_EX_LAYERED or WS_EX_TRANSPARENT;
end;

end.

这是 DFM 代码：

object Form1: TForm1
  Left = 0
  Top = 0
  AlphaBlend = True
  BorderStyle = bsNone
  Caption = 'Form1'
  ClientHeight = 378
  ClientWidth = 589
  Color = clGreen
  TransparentColor = True
  TransparentColorValue = clGreen
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  FormStyle = fsStayOnTop
  OldCreateOrder = False
  Position = poDefault
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Panel1: TPanel
    Left = 0
    Top = 0
    Width = 589
    Height = 378
    Align = alClient
    BevelOuter = bvNone
    Color = clRed
    ParentBackground = False
    TabOrder = 0
    ExplicitLeft = 200
    ExplicitTop = 224
    ExplicitWidth = 185
    ExplicitHeight = 41
    object Panel2: TPanel
      AlignWithMargins = True
      Left = 3
      Top = 3
      Width = 583
      Height = 372
      Align = alClient
      BevelOuter = bvNone
      Color = clGreen
      ParentBackground = False
      ShowCaption = False
      TabOrder = 0
      ExplicitLeft = 200
      ExplicitTop = 176
      ExplicitWidth = 185
      ExplicitHeight = 41
    end
  end
end