{*******************************************************************************
半透明窗体控件
版本:1.0
功能说明 :
1.支持颜色和图片半透明
2.暂时只能手动指定背景图片
3.可调透明度(0..255)
4.可控制是否可移动窗体
联系方式: Email: mdejtoz@163.com
*******************************************************************************}
unit uTranslucentForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ActiveX, Gdiplus,GdipUtil,StdCtrls, XPMan, ExtCtrls;
type
TTranslucentForm = class(TComponent)
private
FAlpha : Byte;
FOverlayerForm : TForm;
FBackground : TFileName;
FOwner : TForm;
FFirstTime : Boolean;
FMouseEvent : TMouseEvent;
FOldOnActive : TNotifyEvent;
FOldOverlayWndProc : TWndMethod;
FMove : Boolean;
procedure SetAlpha(const value : Byte) ;
procedure SetBackground(const value : TFileName);
procedure RenderForm(TransparentValue: Byte);
procedure OverlayWndMethod(var Msg : TMessage);
procedure InitOverForm;
procedure OnOwnerMouseDown(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
procedure OnOwnerActive(Sender : TObject);
procedure SetMove(const value : Boolean);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property AlphaValue : Byte read FAlpha write SetAlpha;
property Background : TFileName read FBackground write SetBackground;
property Move : Boolean read FMove write SetMove;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('MyControl', [TTranslucentForm]);
end;
{ TTranslucentForm }
constructor TTranslucentForm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FOwner := TForm(AOwner);
FAlpha := 255 ;
FMove := True;
if (csDesigning in ComponentState) then Exit;
InitOverForm;
SetWindowLong(FOverlayerForm.Handle,GWL_EXSTYLE,GetWindowLong(FOverlayerForm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
RenderForm(FAlpha);
end;
destructor TTranslucentForm.Destroy;
begin
if not (csDesigning in ComponentState) then
begin
if Assigned(FOverlayerForm) then
begin
FOverlayerForm.WindowProc := FOldOverlayWndProc;
FreeAndNil(FOverlayerForm);
end;
end;
inherited Destroy;
end;
procedure TTranslucentForm.InitOverForm;
begin
FOverlayerForm := TForm.Create(nil);
with FOverlayerForm do
begin
Left := FOwner.Left ;
Top := FOwner.Top;
Width := FOwner.Width ;
Height := FOwner.Height ;
BorderStyle := bsNone;
color := FOwner.Color;
Show;
FOldOverlayWndProc := FOverlayerForm.WindowProc;
FOverlayerForm.WindowProc := OverlayWndMethod;
end;
with FOwner do
begin
Left := FOwner.Left ;
Top := FOwner.Top ;
Color := clOlive;
TransparentColorValue := clOlive;
TransparentColor := True;
BorderStyle := bsNone;
FMouseEvent := OnMouseDown;
FOldOnActive := OnActivate;
OnActivate := OnOwnerActive;
OnMouseDown := OnOwnerMouseDown;
Show;
end;
FFirstTime := True;
RenderForm(FAlpha);
end;
procedure TTranslucentForm.OnOwnerActive(Sender: TObject);
begin
with FOverlayerForm do
begin
Left := FOwner.Left ;
Top := FOwner.Top ;
Width := FOwner.Width ;
Height := FOwner.Height ;
end;
RenderForm(FAlpha);
if Assigned(FOldOnActive) then FOldOnActive(FOwner);
end;
procedure TTranslucentForm.OnOwnerMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Assigned(FOverlayerForm) and FMove then
begin
ReleaseCapture;
SendMessage(FOverlayerForm.Handle,WM_SYSCOMMAND, SC_MOVE or HTCAPTION, 0);
FOwner.Show;
if Assigned(FMouseEvent) then FMouseEvent(Sender,Button,Shift, X, Y);
end;
end;
procedure TTranslucentForm.OverlayWndMethod(var Msg: TMessage);
begin
if (Msg.Msg = WM_MOVE) and FMove then
begin
if Assigned(FOverlayerForm) then
begin
FOwner.Left := FOverlayerForm.Left ;
FOwner.Top := FOverlayerForm.Top ;
end;
end;
if Msg.Msg = CM_ACTIVATE then
begin
if FFirstTime then FOwner.Show;
FFirstTime := False;
end;
FOldOverlayWndProc(Msg);
end;
procedure TTranslucentForm.RenderForm(TransparentValue: Byte);
var
zsize: TSize;
zpoint: TPoint;
zbf: TBlendFunction;
TopLeft: TPoint;
WR: TRect;
GPGraph: TGPGraphics;
m_hdcMemory: HDC;
hdcScreen: HDC;
hBMP: HBITMAP;
FGpBitmap , FBmp: TGpBitmap;
gd : TGpGraphics;
gBrush : TGpSolidBrush;
begin
if (csDesigning in ComponentState) then Exit;
if not FileExists(FBackground) then //如果背景图不存在
begin
FGpBitmap := TGpBitmap.Create(FOwner.Width,FOwner.Height);
gd := TGpGraphics.Create(FGpBitmap);
//颜色画刷
gBrush := TGpSolidBrush.Create(ARGBFromTColor(FOverlayerForm.Color));
//填充
gd.FillRectangle(gBrush,GpRect(0,0,FGpBitmap.Width,FGpBitmap.Height));
FreeAndNil(gd);
FreeAndNil(gBrush);
end
else
begin
try
//读取背景图
FBmp := TGpBitmap.Create(FBackground);
FGpBitmap := TGpBitmap.Create(FOwner.Width,FOwner.Height);
gd := TGpGraphics.Create(FGpBitmap);
gd.DrawImage(FBmp,GpRect(0,0,FGpBitmap.Width,FGpBitmap.Height),0,0,FBmp.Width,FBmp.Height,utPixel);
FreeAndNil(gd);
FreeAndNil(FBmp);
except
Exit;
end;
end;
hdcScreen := GetDC(0);
m_hdcMemory := CreateCompatibleDC(hdcScreen);
hBMP := CreateCompatibleBitmap(hdcScreen, FGpBitmap.Width, FGpBitmap.Height);
SelectObject(m_hdcMemory, hBMP);
GPGraph := TGPGraphics.Create(m_hdcMemory);
try
GPGraph.DrawImage(FGpBitmap, 0, 0, FGpBitmap.Width, FGpBitmap.Height);
zsize.cx := FGpBitmap.Width;
zsize.cy := FGpBitmap.Height;
zpoint := Point(0, 0);
with zbf do
begin
BlendOp := AC_SRC_OVER;
BlendFlags := 0;
SourceConstantAlpha := TransparentValue;
AlphaFormat := AC_SRC_ALPHA;
end;
GetWindowRect(FOverlayerForm.Handle, WR);
TopLeft := WR.TopLeft;
UpdateLayeredWindow(FOverlayerForm.Handle, 0, @TopLeft, @zsize, GPGraph.GetHDC, @zpoint,0, @zbf, 2);
finally
GPGraph.ReleaseHDC(m_hdcMemory);
ReleaseDC(0, hdcScreen);
DeleteObject(hBMP);
DeleteDC(m_hdcMemory);
GPGraph.Free;
end;
FreeAndNil(FGpBitmap);
end;
procedure TTranslucentForm.SetAlpha(const value : Byte);
begin
FAlpha := Value;
RenderForm(FAlpha);
end;
procedure TTranslucentForm.SetBackground(const value: TFileName);
begin
FBackground := value;
RenderForm(FAlpha);
end;
procedure TTranslucentForm.SetMove(const value: Boolean);
begin
FMove := value;
end;
end.
delphi 半透明窗体类
最新推荐文章于 2019-12-17 14:27:17 发布