{============================================================
= AlphaWindow =
= =
= =
= 版本：1.1beta =
= 功能：支持在Win2k下自动实现Alpha过滤窗口效果 =
= 作者：Flier (Flier@stu.ccnu.edu.cn) =
= 日期：2000年8月5日 =
= 版权：你可以在任意商业或非商业程序中使用本控件 =
= 但是在传播此控件时请不要删去以上说明 =
= 历史：2k-8-5 1.1b 修改部分代码顺序，增加执行效率 =
= 2k-8-5 1.0b 测试版发布 =
============================================================}
unit AlphaWindow;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
const
DefaultAlpha = 220;
type
EAlphaWindow = class(Exception);
type
TAlphaWindowFlags = (awColorRef, awAlpha);
TAlphaWindowFlag = set of TAlphaWindowFlags;
type
TAlphaWindow = class(TComponent)
private
OleExStyle: Longint;
FEnabled: Boolean;
FAlpha: Byte;
FAlphaWin: TWinControl;
FKeyColor: TColor;
FFlag: TAlphaWindowFlag;
function IsWin2K: Boolean;
procedure Reset;
procedure SetAlpha(Value: Byte);
procedure SetAlphaWin(Value: TWinControl);
procedure SetEnabled(Value: Boolean);
procedure SetKeyColor(Value: TColor);
procedure SetFlag(Value: TAlphaWindowFlag);
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Enabled: Boolean read FEnabled write SetEnabled;
property Alpha: Byte read FAlpha write SetAlpha default DefaultAlpha;
property AlphaWin: TWinControl read FAlphaWin write SetAlphaWin;
property KeyColor: TColor read FKeyColor write SetKeyColor;
property Flag: TAlphaWindowFlag read FFlag write SetFlag default [awAlph
a];
end;
procedure Register;
implementation
const
user32 = 'user32.dll';
WS_EX_LAYERED = $00080000;
LWA_COLORKEY = $00000001;
LWA_ALPHA = $00000002;
{
ULW_COLORKEY = $00000001;
ULW_ALPHA = $00000002;
ULW_OPAQUE = $00000004;
function UpdateLayeredWindow(hWnd: HWND;
hdcDst: HDC; pptDst: PPoint; pSize: PSize;
hdcSrc: HDC; pptSrc: PPoint;
crKey: TColorRef;
pBlend: PBlendFunction;
dwFlags: DWord): BOOL; stdcall;
external user32
name 'UpdateLayeredWindow';
}
function SetLayeredWindowAttributes(hWnd: HWND;
crKey: TColorRef;
bAlpha: Byte;
dwFlags: DWord): BOOL; stdcall;
external user32
name 'SetLayeredWindowAttributes';
constructor TAlphaWindow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFlag := [awAlpha];
FAlpha := DefaultAlpha;
FAlphaWin := nil;
if Owner is TWinControl then
FAlphaWin := Owner as TWinControl
else
FAlphaWin := nil;
end;
destructor TAlphaWindow.Destroy;
begin
if csDesigning in ComponentState then
Enabled := False;
inherited Destroy;
end;
function TAlphaWindow.IsWin2K: Boolean;
begin
Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and
(Win32MajorVersion >= 5);
end;
procedure TAlphaWindow.Reset;
const
ColorRefFlag: array[Boolean] of DWord = (0, LWA_COLORKEY);
AlphaFlag: array[Boolean] of DWord = (0, LWA_ALPHA);
begin
if FEnabled then
begin
SetLayeredWindowAttributes(FAlphaWin.Handle,
ColorToRGB(FKeyColor),
FAlpha,
ColorRefFlag[awColorRef in FFlag] or
AlphaFlag[awAlpha in FFlag]);
end;
end;
procedure TAlphaWindow.SetEnabled(Value: Boolean);
var
r: TRect;
begin
if not IsWin2K or
not Assigned(FAlphaWin) or
not IsWindow(FAlphaWin.Handle) then
begin
FEnabled := False
end
else
begin
if FEnabled <> Value then
begin
FEnabled := Value;
if FEnabled then
begin
OleExStyle := GetWindowLong(FAlphaWin.Handle, GWL_EXSTYLE);
SetWindowLong(FAlphaWin.Handle, GWL_EXSTYLE, OleExStyle or WS_EX_LAY
ERED);
Reset;
end
else
begin
SetWindowLong(FAlphaWin.Handle, GWL_EXSTYLE, OleExStyle);
GetWindowRect(FAlphaWin.Handle, r);
InvalidateRect(FAlphaWin.Handle, @r, True);
end;
end;
end;
end;
procedure TAlphaWindow.SetAlphaWin(Value: TWinControl);
var
b: Boolean;
begin
if FAlphaWin <> Value then
begin
b := Enabled;
Enabled := False; // 注意这里两个是Enabled不是FEnabled
FAlphaWin := Value; // 因为需要将以前的窗口恢复原状态
Enabled := b; // 并且检查新设置的窗口是否可用
Reset;
end;
end;
procedure TAlphaWindow.SetAlpha(Value: Byte);
begin
if FAlpha <> Value then
begin
FAlpha := Value;
Reset;
end;
end;
procedure TAlphaWindow.SetKeyColor(Value: TColor);
begin
if FKeyColor <> Value then
begin
FKeyColor := Value;
Reset;
end;
end;
procedure TAlphaWindow.SetFlag(Value: TAlphaWindowFlag);
begin
if FFlag <> Value then
begin
FFlag := Value;
Reset;
end;
end;
procedure Register;
begin
RegisterComponents('Flier', [TAlphaWindow]);
end;
end.