如何创建继承自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
相关产品推荐
相关产品推荐

