You need to enable JavaScript to run this app.
优惠活动
大模型
产品
解决方案
定价
更多

如何创建继承自TCustomControl的透明组件并解决遮挡问题?

问题:自定义半透明组件被子控件遮挡

我需要创建一个继承自TCustomControl的透明组件,要求:

  • 绘制覆盖整个父容器的半透明矩形
  • 覆盖所有可视组件
  • 不能使用TCustomTransparentControl

现有实现代码如下,当前运行时组件被父容器内的Edit控件遮挡,已尝试设置ControlStyle := ControlStyle + [csOpaque];但未解决问题。


组件代码:CustomTransparente.pas

unit CustomTransparente;

interface

uses
  System.SysUtils,
  System.Classes,
  System.NetEncoding,
  Winapi.Windows,
  Winapi.D2D1,
  Winapi.Messages,
  Vcl.ExtCtrls,
  Vcl.Graphics,
  Vcl.Direct2D,
  Vcl.Controls,
  Vcl.StdCtrls,
  Vcl.Forms;

type
  TCustomTransparente = class(TCustomControl)
  private
    FColor         : TColor;
    FTitleLabel    : TLabel;
    procedure InitialComponent(ATitle : String);
    procedure CreateTitle(ATitle : String);
  protected
    procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent; ATitle : String); reintroduce;
    destructor Destroy(); override;
  published
  end;

implementation

{ TCustomTransparente }

constructor TCustomTransparente.Create(AOwner: TComponent; ATitle : String);
begin
  inherited Create(AOwner);
  DoubleBuffered         := True;
  ControlStyle           := ControlStyle + [csOpaque];
  FColor                 := clWhite;
  ParentBackground       := False;
  Width                  := TControl(AOwner).Width;
  Top                    := TControl(AOwner).Top ;
  Height                 := TControl(AOwner).Height;
  StyleElements          := [];
  InitialComponent(ATitle);
end;

procedure TCustomTransparente.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;

procedure TCustomTransparente.CreateTitle(ATitle : String);
begin
  if not Assigned(FTitleLabel) then
  begin
    FTitleLabel              := TLabel.Create(Self);
    FTitleLabel.Parent       := Self;
    FTitleLabel.Font.Name    := 'Tahoma';
    FTitleLabel.Font.Size    := 10;
    FTitleLabel.Caption      := ATitle;
    FTitleLabel.Left         := (Width) div 2;
    FTitleLabel.Top          := (Height) div 2;
    FTitleLabel.Height       := 20;
    FTitleLabel.Color        := clBtnFace;
    FTitleLabel.Transparent  := True;
    FTitleLabel.Font.Color   := clBlack;
    FTitleLabel.Font.Quality := fqClearType;
    FTitleLabel.AutoSize     := False;
    FTitleLabel.Alignment    := taCenter;
  end;
end;

destructor TCustomTransparente.Destroy;
begin
  FTitleLabel.Free;
  inherited;
end;


procedure TCustomTransparente.InitialComponent(ATitle : String);
begin
  CreateTitle(ATitle);
end;

procedure TCustomTransparente.Paint;
var
  LRoundRect       : TD2D1RoundedRect;
  RectF            : TD2D1RectF;
  SolidColorBrush  : ID2D1SolidColorBrush;
  ColorF           : TD2D1ColorF;
  LCanvas          : TDirect2DCanvas;
begin
  LCanvas := TDirect2DCanvas.Create(Canvas, ClientRect);
  LCanvas.BeginDraw;
  try
    RectF.left   := 1;
    RectF.top    := 1;
    RectF.right  := Width-2;
    RectF.bottom := Height-2;

    LRoundRect.rect    := RectF;
    LRoundRect.radiusX := 16;
    LRoundRect.radiusY := 16;

    ColorF.r := GetRValue(FColor) / 255;
    ColorF.g := GetGValue(FColor) / 255;
    ColorF.b := GetBValue(FColor) / 255;
    ColorF.a := 0.7;

    LCanvas.RenderTarget.CreateSolidColorBrush(ColorF, nil, SolidColorBrush);
    LCanvas.Pen.Width := 1;

    LCanvas.RenderTarget.FillRoundedRectangle(LRoundRect, SolidColorBrush);
  finally
    LCanvas.EndDraw;
    LCanvas.Free;
  end;
end;

procedure TCustomTransparente.WMWindowPosChanging(var Message: TWMWindowPosChanging);
begin
  inherited;
  BringToFront;
  with Message.WindowPos^ do
    flags := flags or SWP_NOZORDER;
end;

end.

组件包装类:uMessageCustom.pas

unit uMessageCustom;

interface

uses
  Winapi.Windows,
  System.Classes,
  Vcl.Controls,
  CustomTransparente,
  Vcl.Forms,
  Vcl.Dialogs;


type
  TMessageCustom = class(TComponent)
  private
    FCustomTransparente: TCustomTransparente;
    FOwner        : TWinControl;
  public
    procedure Show(pParent: TWinControl; const pTitle : string);
    procedure Hide;
  end;


procedure Register;

implementation

procedure TMessageCustom.Hide;
begin
  if Assigned(FCustomTransparente) then
  begin
    FOwner.Enabled := True;
    FCustomTransparente.Free;
    FCustomTransparente := nil;
  end;
end;

procedure TMessageCustom.Show(pParent: TWinControl; const pTitle : string);
begin
  FCustomTransparente           := TCustomTransparente.Create(pParent, pTitle);
  FCustomTransparente.Parent    := pParent;
  FOwner                        := pParent;
  FOwner.Enabled                := False;
  Application.ProcessMessages;
end;

procedure Register;
begin
 RegisterComponents('Samples', [TMessageCustom]);
end;

end.

测试窗体代码:Unit1.pas

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, CustomTransparente, Vcl.StdCtrls, uMessageCustom;

type
  TForm1 = class(TForm)
    MessageCustom1: TMessageCustom;
    Button1: TButton;
    Panel1: TPanel;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
 MessageCustom1.Show(Panel1, 'Hello World');
end;

end.

窗体DFM文件

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 313
  ClientWidth = 578
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Button1: TButton
    Left = 248
    Top = 280
    Width = 75
    Height = 25
    Caption = 'Button1'
    TabOrder = 0
    OnClick = Button1Click
  end
  object Panel1: TPanel
    Left = 0
    Top = 0
    Width = 577
    Height = 274
    Color = clWhite
    ParentBackground = False
    TabOrder = 1
    object Edit1: TEdit
      Left = 272
      Top = 127
      Width = 121
      Height = 21
      TabOrder = 0
      Text = 'Edit1'
    end
  end
  object MessageCustom1: TMessageCustom
    Left = 504
    Top = 24
  end
end

问题现象

运行时点击Button1,半透明组件显示后被Panel内的Edit控件遮挡,无法覆盖所有子控件。


内容的提问来源于stack exchange,提问作者Daiane Sampaio

相关产品推荐
方舟 Agent Plan

超全模态模型 × Harness 升级,最新支持 Deepseek-V4.1-Flash、GLM-5.3 系列、Doubao-Seedream-5.0-pro、Kimi-K3 (部分), 限时 9.9 元起

最近更新时间:2026.07.03 07:57:07