How do I put a semi transparent layer on my form
Create a new VCL project. Add a few sample buttons and other controls to the main form. Create a new form, set AlphaBlend
to true
and AlphaBlendValue
to 128
. Perhaps Color = clSkyBlue
will suffice? Then add the following procedure to your main form:
procedure TForm1.UpdateShadow;
var
pnt: TPoint;
rgn, rgnCtrl: HRGN;
i: Integer;
begin
if not Assigned(Form2) then Exit;
Form2.Show;
pnt := ClientToScreen(Point(0, 0));
Form2.SetBounds(pnt.X, pnt.Y, ClientWidth, ClientHeight);
rgn := CreateRectRgn(0, 0, Form2.Width, Form2.Height);
for i := 0 to ControlCount - 1 do
if Controls[i].Tag = 1 then
begin
if not (Controls[i] is TWinControl) then Continue;
with Controls[i] do
rgnCtrl := CreateRectRgn(Left, Top, Left+Width, Top+Height);
CombineRgn(rgn, rgn, rgnCtrl, RGN_DIFF);
DeleteObject(rgnCtrl);
end;
SetWindowRgn(Form2.Handle, rgn, true);
DeleteObject(rgn);
end;
and call this on resize,
procedure TForm1.FormResize(Sender: TObject);
begin
UpdateShadow;
end;
and form move:
procedure TForm1.WMMove(var Message: TWMMove);
begin
inherited;
UpdateShadow;
end;
Finally, set the Tag
to 1
on the controls (on your main form) that are to be accessible.
(source: rejbrand.se)
Hint: You might also wish to set the Cursor
of the 'shadow form' to crNo
.
Here is an demo app using an alpha blended transparent TForm as the fade shadow. The main difference between this and Andreas's example is that this code handles nested controls and does not use any window regions.
MainForm.pas:
unit MainForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls, ExtCtrls, Shadow;
type
TShadowTestForm = class(TForm)
Button1: TButton;
Button2: TButton;
Panel1: TPanel;
Button3: TButton;
Button4: TButton;
Panel2: TPanel;
Button5: TButton;
procedure Button1Click(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
Shadow: TShadowForm;
procedure WMMove(var Message: TWMMove); message WM_MOVE;
public
{ Public declarations }
end;
var
ShadowTestForm: TShadowTestForm;
implementation
{$R *.dfm}
procedure TShadowTestForm.Button1Click(Sender: TObject);
begin
if not Assigned(Shadow) then
begin
Shadow := TShadowForm.CreateShadow(Self);
Shadow.UpdateShadow;
Button1.Caption := 'Hide Shadow';
Button4.Caption := 'Show Modal Form';
end else
begin
FreeAndNil(Shadow);
Button1.Caption := 'Show Shadow';
Button4.Caption := 'Test Click';
end;
end;
procedure TShadowTestForm.Button2Click(Sender: TObject);
begin
ShowMessage('clicked ' + TControl(Sender).Name);
end;
procedure TShadowTestForm.Button4Click(Sender: TObject);
var
tmpFrm: TForm;
begin
if Assigned(Shadow) then
begin
tmpFrm := TShadowTestForm.Create(nil);
try
tmpFrm.ShowModal;
finally
tmpFrm.Free;
end;
end else
Button2Click(Sender);
end;
procedure TShadowTestForm.Button5Click(Sender: TObject);
begin
TShadowTestForm.Create(Self).Show;
end;
procedure TShadowTestForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if not (fsModal in FormState) then
Action := caFree;
end;
procedure TShadowTestForm.FormResize(Sender: TObject);
begin
if Assigned(Shadow) then Shadow.UpdateShadow;
end;
procedure TShadowTestForm.WMMove(var Message: TWMMove);
begin
inherited;
if Assigned(Shadow) then Shadow.UpdateShadow;
end;
end.
MainForm.dfm:
object ShadowTestForm: TShadowTestForm
Left = 0
Top = 0
Caption = 'Shadow Test Form'
ClientHeight = 243
ClientWidth = 527
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PopupMode = pmExplicit
Position = poScreenCenter
OnClose = FormClose
OnResize = FormResize
PixelsPerInch = 96
TextHeight = 13
object Button1: TButton
Tag = 1
Left = 320
Top = 192
Width = 97
Height = 25
Caption = 'Show Shadow'
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 64
Top = 56
Width = 75
Height = 25
Caption = 'Test Click'
TabOrder = 1
OnClick = Button2Click
end
object Panel1: TPanel
Left = 192
Top = 40
Width = 289
Height = 105
Caption = 'Panel1'
TabOrder = 2
object Button3: TButton
Left = 24
Top = 16
Width = 75
Height = 25
Caption = 'Test Click'
TabOrder = 0
OnClick = Button2Click
end
object Button4: TButton
Tag = 1
Left = 72
Top = 72
Width = 129
Height = 25
Caption = 'Test Click'
TabOrder = 1
OnClick = Button4Click
end
end
object Panel2: TPanel
Tag = 1
Left = 24
Top = 151
Width = 233
Height = 84
Caption = 'Panel2'
TabOrder = 3
object Button5: TButton
Tag = 1
Left = 22
Top = 48
Width = 155
Height = 25
Caption = 'Show NonModal Form'
TabOrder = 0
OnClick = Button5Click
end
end
end
Shadow.pas:
unit Shadow;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms, Dialogs;
type
TShadowForm = class(TForm)
private
{ Private declarations }
FBmp: TBitmap;
procedure FillControlRect(Control: TControl);
procedure FillControlRects(Control: TWinControl);
protected
procedure Paint; override;
procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;
procedure WMDisplayChange(var Message: TMessage); message WM_DISPLAYCHANGE;
public
{ Public declarations }
constructor CreateShadow(AForm: TForm);
destructor Destroy; override;
procedure UpdateShadow;
end;
implementation
{$R *.dfm}
constructor TShadowForm.CreateShadow(AForm: TForm);
begin
inherited Create(AForm);
PopupParent := AForm;
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf24bit;
end;
destructor TShadowForm.Destroy;
begin
FBmp.Free;
inherited;
end;
procedure TShadowForm.Paint;
begin
Canvas.Draw(0, 0, FBmp);
end;
procedure TShadowForm.FillControlRect(Control: TControl);
var
I: Integer;
R: TRect;
begin
if Control.Tag = 1 then
begin
R := Control.BoundsRect;
MapWindowPoints(Control.Parent.Handle, PopupParent.Handle, R, 2);
FBmp.Canvas.FillRect(R);
end;
if Control is TWinControl then
FillControlRects(TWinControl(Control));
end;
procedure TShadowForm.FillControlRects(Control: TWinControl);
var
I: Integer;
begin
for I := 0 to Control.ControlCount-1 do
FillControlRect(Control.Controls[I]);
end;
procedure TShadowForm.UpdateShadow;
var
Pt: TPoint;
R: TRect;
begin
Pt := PopupParent.ClientOrigin;
R := PopupParent.ClientRect;
FBmp.Width := R.Right - R.Left;
FBmp.Height := R.Bottom - R.Top;
FBmp.Canvas.Brush.Color := clSkyBlue;
FBmp.Canvas.FillRect(Rect(0, 0, FBmp.Width, FBmp.Height));
FBmp.Canvas.Brush.Color := TransparentColorValue;
FillControlRects(PopupParent);
SetBounds(Pt.X, Pt.Y, FBmp.Width, FBmp.Height);
if Showing then
Invalidate
else
ShowWindow(Handle, SW_SHOWNOACTIVATE);
end;
procedure TShadowForm.WMDisplayChange(var Message: TMessage);
begin
inherited;
UpdateShadow;
end;
procedure TShadowForm.WMMouseActivate(var Message: TWMMouseActivate);
begin
Message.Result := MA_NOACTIVATE;
end;
end.
Shadow.dfm:
object ShadowForm: TShadowForm
Left = 0
Top = 0
Cursor = crNo
AlphaBlend = True
AlphaBlendValue = 128
BorderStyle = bsNone
Caption = 'Shadow'
ClientHeight = 281
ClientWidth = 543
Color = clBtnFace
TransparentColor = True
TransparentColorValue = clFuchsia
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PopupMode = pmExplicit
Position = poDesigned
PixelsPerInch = 96
TextHeight = 13
end
ShadowDemo.dpr:
program ShadowDemo;
uses
Forms,
ShadowTestForm in 'MainForm.pas' {ShadowTestForm},
Shadow in 'Shadow.pas' {ShadowForm};
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TShadowTestForm, ShadowTestForm);
Application.Run;
end.