关于delphi：如何在表单上放半透明层


How do I put a semi transparent layer on my form

上周我在 stackoverflow 上阅读了一些关于此的问题。

我的要求也差不多。

我需要在我的表单顶部放置一个半透明层，但是这个表单可能还有其他几个组件：列表、编辑、标签、图像等

我需要这个半透明层来覆盖所有这些。

这个想法是淡化表单中那些不使用或无法访问的区域。

我使用的是 Delphi 2007。

谢谢

相关讨论

这是一个使用 alpha 混合透明 TForm 作为渐变阴影的演示应用程序。这与 Andreas 的示例之间的主要区别在于，此代码处理嵌套控件并且不使用任何窗口区域。

Normal

Shadowed

MainForm.pas:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
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:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
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:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
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:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
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:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
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.
相关讨论

创建一个新的 VCL 项目。向主窗体添加一些示例按钮和其他控件。创建一个新表单，将 AlphaBlend 设置为 true 并将 AlphaBlendValue 设置为 128。也许 Color = clSkyBlue 就足够了？然后将以下过程添加到您的主窗体：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
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;

并在调整大小时调用它，

1
2
3
4
procedure TForm1.FormResize(Sender: TObject);
begin
  UpdateShadow;
end;

和表格移动：

1
2
3
4
5
procedure TForm1.WMMove(var Message: TWMMove);
begin
  inherited;
  UpdateShadow;
end;

最后，在要访问的控件(在您的主窗体上)上将 Tag 设置为 1。

Sample

相关讨论