一个可设置窗口透明属性的控件，可让窗口透明、半透明

{
define __STATIC_STYLE__
}
unit UPHMTransWin;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Dialogs, Forms;

type
TWinFlags = (fColorKey, fAlphaKey, fBoth);

TPHMTransWin = class(TComponent)
private
{
Private declarations
}
FdwFlags : DWord;
FColorKey : TColor;
FAlpha : Byte;
FHandle : HWND;
FWinFlags : TWinFlags;
FWinControl: TWinControl;
procedure SetWinFlags(Value: TWinFlags);
procedure SetWinControl(Value: TWinControl);
procedure SetAlpha(Value: Byte);
procedure SetColorKey(Value: TColor);
procedure DoRefresh;
protected
{
Protected declarations
}
public
{
Public declarations
}
property WinCtrl: TWinControl read FWinControl write SetWinControl;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{
Published declarations
}
property WinFlags: TWinFlags read FWinFlags write SetWinFlags;
property Alpha : Byte read FAlpha write SetAlpha;
property ColorKey: TColor read FColorKey write SetColorKey;
property Handle : HWND read FHandle write FHandle;
end;

procedure Register;

implementation

const
lwa_ColorKey = 1;
lwa_Alpha = 2;
ws_Ex_Layered = $80000;

{
$ifdef __STATIC_STYLE__
}
type
TSetLayeredWindowAttributes = function(Wnd: hwnd; crKey: ColorRef; bAlpha: Byte; dwFlags: DWord): Boolean; stdcall;
var
SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
DllHandle: THandle;
{
$else
}
function SetLayeredWindowAttributes(Wnd: hwnd; crKey: ColorRef; bAlpha: Byte; dwFlags: DWord): boolean; stdcall; external 'user32.dll';
{
$endif
}

//---------------------------------------------------------------------------
procedure register;
begin
RegisterComponents('Win Effects', [TPHMTransWin]);
end;

//---------------------------------------------------------------------------
constructor TPHMTransWin.Create(AOwner: TComponent);
begin
inherited Create(AOwner);

WinFlags := fAlphaKey;
Alpha := 255;
ColorKey := clBlack;
FHandle := 0;
end;

//---------------------------------------------------------------------------
destructor TPHMTransWin.Destroy;
begin
inherited;
end;

//---------------------------------------------------------------------------
procedure TPHMTransWin.SetColorKey(Value: TColor);
begin
if (Value <> FColorKey) then
begin
FColorKey := Value;
DoRefresh;
end;
end;

//---------------------------------------------------------------------------
procedure TPHMTransWin.SetAlpha(Value: Byte);
begin
if (Value <> FAlpha) then
begin
FAlpha := Value;
DoRefresh;
end;
end;

//---------------------------------------------------------------------------
procedure TPHMTransWin.SetWinFlags(Value: TWinFlags);
begin
if (Value <> FWinFlags) then
begin
FWinFlags := Value;

if (FWinFlags = fAlphaKey) then
begin
FdwFlags := lwa_Alpha;
end
else if (FWinFlags = fBoth) then
begin
FdwFlags := lwa_Alpha or lwa_ColorKey;
end
else
begin
FdwFlags := lwa_ColorKey;
end;

DoRefresh;
end;
end;

//---------------------------------------------------------------------------
procedure TPHMTransWin.SetWinControl(Value: TWinControl);
begin
if ((Value <> FWinControl) and (Value <> nil)) then
begin
FWinControl := Value;
FHandle := FWinControl.Handle;

if not(csDesigning in ComponentState) then
begin
SetWindowLong(FHandle, gwl_ExStyle, GetWindowLong(FHandle, gwl_ExStyle) or ws_Ex_Layered);
DoRefresh;
end;
end;
end;

//---------------------------------------------------------------------------
procedure TPHMTransWin.DoRefresh;
begin
if ((FHandle > 0) and not(csDesigning in ComponentState)) then
begin
SetLayeredWindowAttributes(FHandle, ColorToRGB(FColorKey), FAlpha, FdwFlags);
end;
end;

{
$ifdef __STATIC_STYLE__
}
//---------------------------------------------------------------------------
initialization
DllHandle := LoadLibrary('user32.dll');
@SetLayeredWindowAttributes := nil;
if DllHandle <> 0 then
begin
@SetLayeredWindowAttributes := GetProcAddress(DllHandle, 'SetLayeredWindowAttributes');
if @SetLayeredWindowAttributes = nil then
begin
ShowMessage('OS Must be Windows 2000!');
Halt;
end;
end;

//---------------------------------------------------------------------------
finalization
if DllHandle <> 0 then FreeLibrary(DllHandle);
{
$endif
}

end.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, UPHMTransWin;

type
TForm1 = class(TForm)
PHMTransWin1: TPHMTransWin;
Button1: TButton;
Button2: TButton;
Button3: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{
Private declarations
}
public
{
Public declarations
}
end;

var
Form1: TForm1;

implementation

{
$R *.DFM
}

procedure TForm1.Button1Click(Sender: TObject);
begin
PHMTransWin1.WinCtrl := Self;
PHMTransWin1.ColorKey := Self.Color;
PHMTransWin1.WinFlags := fColorKey;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
PHMTransWin1.WinCtrl := Self;
PHMTransWin1.ColorKey := Self.Color;
PHMTransWin1.Alpha := 32;
PHMTransWin1.WinFlags := fAlphaKey;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
PHMTransWin1.WinCtrl := Self;
PHMTransWin1.ColorKey := Self.Color;
PHMTransWin1.Alpha := 128;
PHMTransWin1.WinFlags := fBoth;
end;

end.