DELPHI 透明窗体
心血来潮想用delphi做透明窗体,要知道我虽然搞了N年编程,但什么也没编写成。惭愧的很,以前VCVB之类的光搞懂它们的控件就让我很费劲,没办法不懂英文。还是学DELPHI吧,听说是聪明程序员学习的语言。在网络上搜索下透明窗体,哈文章不少,视频也有,但都太繁琐,关键看不懂,总算有个简单的,实验成功了哈哈。博下来以后用: unit StyleForm; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; const WS_EX_LAYERED = $80000; AC_SRC_OVER = $0; AC_SRC_ALPHA = $1; AC_SRC_NO_PREMULT_ALPHA = $1; AC_SRC_NO_ALPHA = $2; AC_DST_NO_PREMULT_ALPHA = $10; AC_DST_NO_ALPHA = $20; LWA_COLORKEY = $1; LWA_ALPHA = $2; ULW_COLORKEY = $1; ULW_ALPHA = $2; ULW_OPAQUE = $4; type TForm1 = class(TForm) Button1: TButton; procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; function SetLayeredWindowAttributes(hwnd:HWND; crKey:Longint; bAlpha:byte; dwFlags:longint ):longint; stdcall; external user32; var Form1: TForm1; implementation {$R *.dfm} procedure TForm1.FormCreate(Sender: TObject); var I:longint; begin Form1.Brush.Color:=rgb(0,0,0); I:=getWindowLong(Handle, GWL_EXSTYLE); I:= I Or WS_EX_LAYERED; SetWindowLong (handle, GWL_EXSTYLE, I); SetLayeredWindowAttributes (handle, 0, 123, LWA_ALPHA); end; end. 后来又在网络上搜索了下发现有个更简单的: 只要在窗体的创建中加入 form1.AlphaBlend:=true; form1.AlphaBlendValue:=100; 就行了。真晕!
DELPHI 异形窗体
一定有很多人看到过一些奇形怪状的窗体,例如一些屏幕精灵。其实实现起来非常容易,做到三点就好啦。下面我使用Delphi做了一个VCL控件(TBmpShape),你只需要指定一幅图片就可以将窗体变成你的图片的形状。 1。准备一幅位图图片,一定要BMP格式的 2。将VCL控件放在你的窗体(FORM)上,注意不能是其他的容器,设置PICTURE属性,指定制作好的图片。 3。设置图片的背景颜色,必须是你的图片的背景颜色准确值 4。在本窗体的FormCreate事件中写一行代码 BmpShape1.Apply; 做到上面四点就可以了,编译运行你的窗体,是不是不一样啊。 下面是具体的代码,不是太长吧。 unit BmpShape; { 2002/08/22 by ultrared 根据BMP文件创建窗口 注意: 1. BMP文件最左上的一个点颜色作为背景色 2. BmpShape控件只能用在TForm容器上 3. BMP文件可以是256色或者24位色 4。大块背景色必须和背景色绝对相等才能获得正常效果 } interface uses Forms,Windows, Messages, SysUtils, Classes, Controls, ExtCtrls,Graphics; type TBmpShape = class(TImage) private { Private declarations } BackColor:TColor;//背景颜色 FColorDither:boolean;//是否允许背景颜色有一定的抖动 function GetRegion:HRGN;//前景图片的区域 procedure setColorDither(cd:Boolean); protected { Protected declarations } public { Public declarations } constructor Create(AOwner:TComponent);override; procedure Apply;//使用效果 published { Published declarations } property Dither:Boolean read FColorDither write setColorDither; end; procedure Register; implementation procedure Register; begin RegisterComponents('Samples', ); end; procedure TBmpShape.setColorDither(cd:Boolean); begin if cd<>FColorDither then FColorDither:=cd; end; constructor TBmpShape.Create(AOwner:TComponent); begin inherited Create(AOwner); BackColor:=RGB(0,0,0); FColorDither:=FALSE; end; //核心子程序,获得BMP图片的前景区域 function TBmpShape.GetRegion:HRGN; var i,j:integer; rgn1,rgn2:HRGN; StartY:integer; r,g,b,r1,g1,b1:BYTE; cc:TColor; begin if Picture.Bitmap<>nil then begin BackColor:=Picture.Bitmap.Canvas.Pixels[0,0]; rgn1:=CreateRectRgn(0,0,0,0); for i:=0 to Picture.Bitmap.Width-1 do begin StartY:=-1; for j:=0 to Picture.Bitmap.Height-1 do begin cc:=Picture.Bitmap.Canvas.Pixels[i,j]; if FColorDither then begin //允许和背景有一定的色差 r:=(cc and $FF0000) shr 16; g:=(cc and $FF00) shr 8; b:=cc and $FF; r1:=(BackColor and $FF0000) shr 16; g1:=(BackColor and $FF00) shr 8; b1:=BackColor and $FF; if (abs(r-r1)<10) and (abs(g-g1)<10) and (abs(b-b1)<10) then begin if (StartY>=0) and (j>=StartY) then begin rgn2:=CreateRectRgn(i,StartY,i+1,j); CombineRgn(rgn1,rgn1,rgn2,RGN_OR); StartY:=-1; end; end else begin if Starty<0 then StartY:=j else if j=(Picture.Bitmap.Height-1) then //最下面一个点 begin rgn2:=CreateRectRgn(i,StartY,i+1,j); CombineRgn(rgn1,rgn1,rgn2,RGN_OR); end; end; end else //不允许色差 begin if cc=BackColor then begin if (StartY>=0) and (j>=StartY) then begin rgn2:=CreateRectRgn(i,StartY,i+1,j); CombineRgn(rgn1,rgn1,rgn2,RGN_OR); StartY:=-1; end; end else begin if Starty<0 then StartY:=j else if j=(Picture.Bitmap.Height-1) then //最下面一个点 begin rgn2:=CreateRectRgn(i,StartY,i+1,j); CombineRgn(rgn1,rgn1,rgn2,RGN_OR); end; end; end; end; end; result:=rgn1; end else result:=0; end; procedure TBmpShape.Apply; begin if Parent is TForm then begin Left:=0; Top:=0; Width:=Picture.Bitmap.Width; Height:=Picture.Bitmap.Height; with (Parent as Tform) do begin BorderStyle:=bsNone; Width:=Self.Width; Height:=Self.Height; end; SetWindowRgn(Parent.Handle,GetRegion,FALSE); end; end; end.
Delphi磁性窗口
昨天要用到磁性窗口,就是两个窗口离得近到一个距离就吸附到一起.拖动主窗口,吸附窗体一块运动. 到网上搜了一下,基本没见到可以使用的.有个东东,还是收费的.没办法自己写了一个. 用法很简单,把你的窗口都改成从这个继承即可生效.例如 type TForm3 = class(TCustomMagnetForm) private { Private declarations } public { Public declarations } end; var Form3: TForm3; 不多说了,上代码 { ******************************************************* } { } { 磁性吸附窗口 } { } { 版权所有 (C) 2011 wr960204武稀松 } { } { ******************************************************* } unit MagnetForm; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Generics.Collections; type TCustomMagnetForm = class(TForm) private type TMagnetFormList = TList<TCustomMagnetForm>; class var // 吸附距离 FMagnetBuffer: Integer; var // 吸附子窗口容器 FMagnetClientList: TMagnetFormList; // 相对主窗口的位置 FMagnetPosOffset: TPoint; // 可否随主窗口移动 FEnableMagnetMoveClient: Boolean; // 移除子窗口 procedure RemoveMagnetForm(AForm: TCustomMagnetForm); // 添加子窗口 procedure AddMagnetForm(AForm: TCustomMagnetForm; Value: TPoint); // 处理子窗口吸附 function ProcessClient(var ServerBound, ClientBound: TRect): Boolean; // 处理主窗口吸附 function ProcessServer(var ServerBound, ClientBound: TRect; AClient: TCustomMagnetForm): Boolean; // 主窗口移动 procedure ProcessServerMove(); protected procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING; procedure WMMoving(var Message: TWMMoving); message WM_MOVING; procedure WMMove(var Message: TWMMove); message WM_MOVE; procedure DoClose(var Action: TCloseAction); override; procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; class property MagnetBuffer: Integer read FMagnetBuffer write FMagnetBuffer; end; implementation { TCustomMagnetForm } constructor TCustomMagnetForm.Create(AOwner: TComponent); begin inherited Create(AOwner); FMagnetClientList := TMagnetFormList.Create; end; destructor TCustomMagnetForm.Destroy; begin if Self <> Application.MainForm then RemoveMagnetForm(Self); FMagnetClientList.Free; inherited Destroy; end; procedure TCustomMagnetForm.DoClose(var Action: TCloseAction); begin inherited DoClose(Action); if Self <> Application.MainForm then RemoveMagnetForm(Self); end; function TCustomMagnetForm.ProcessClient(var ServerBound, ClientBound: TRect): Boolean; var lspace, rspace, tspace, bspace: Integer; begin Result := False; lspace := ABS(ClientBound.Right - ServerBound.Left); rspace := ABS(ClientBound.Left - ServerBound.Right); tspace := ABS(ClientBound.Bottom - ServerBound.Top); bspace := ABS(ClientBound.Top - ServerBound.Bottom); FMagnetPosOffset := Point(ClientBound.Left - ServerBound.Left, ClientBound.Top - ServerBound.Top); if (ClientBound.Bottom > ServerBound.Top) and (ClientBound.Top < ServerBound.Bottom) then begin if lspace < rspace then begin if lspace < FMagnetBuffer then begin AddMagnetForm(Self, Point(ClientBound.Left - ServerBound.Left, ClientBound.Top - ServerBound.Top)); OffsetRect(ClientBound, (ServerBound.Left - ClientBound.Right), 0); Result := True; end; end else begin if rspace < FMagnetBuffer then begin AddMagnetForm(Self, Point(ClientBound.Left - ServerBound.Left, ClientBound.Top - ServerBound.Top)); OffsetRect(ClientBound, (ServerBound.Right - ClientBound.Left), 0); Result := True; end; end; end; if (ClientBound.Right > ServerBound.Left) and (ClientBound.Left < ServerBound.Right) then begin if tspace < bspace then begin if tspace < FMagnetBuffer then begin AddMagnetForm(Self, Point(ClientBound.Left - ServerBound.Left, ClientBound.Top - ServerBound.Top)); OffsetRect(ClientBound, 0, ServerBound.Top - ClientBound.Bottom); Result := True; end; end else begin if bspace < FMagnetBuffer then begin AddMagnetForm(Self, Point(ClientBound.Left - ServerBound.Left, ClientBound.Top - ServerBound.Top)); OffsetRect(ClientBound, 0, ServerBound.Bottom - ClientBound.Top); Result := True; end; end; end; end; function TCustomMagnetForm.ProcessServer(var ServerBound, ClientBound: TRect; AClient: TCustomMagnetForm): Boolean; var lspace, rspace, tspace, bspace: Integer; begin Result := False; lspace := ABS(ClientBound.Right - ServerBound.Left); rspace := ABS(ClientBound.Left - ServerBound.Right); tspace := ABS(ClientBound.Bottom - ServerBound.Top); bspace := ABS(ClientBound.Top - ServerBound.Bottom); FMagnetPosOffset := Point(ClientBound.Left - ServerBound.Left, ClientBound.Top - ServerBound.Top); if (ClientBound.Bottom > ServerBound.Top) and (ClientBound.Top < ServerBound.Bottom) then begin if lspace < rspace then begin if lspace < FMagnetBuffer then begin AddMagnetForm(AClient, Point(ClientBound.Left - ServerBound.Left, ClientBound.Top - ServerBound.Top)); OffsetRect(ServerBound, -(ServerBound.Left - ClientBound.Right), 0); Result := True; end; end else begin if rspace < FMagnetBuffer then begin AddMagnetForm(AClient, Point(ClientBound.Left - ServerBound.Left, ClientBound.Top - ServerBound.Top)); OffsetRect(ServerBound, -(ServerBound.Right - ClientBound.Left), 0); Result := True; end; end; end; if (ClientBound.Right > ServerBound.Left) and (ClientBound.Left < ServerBound.Right) then begin if tspace < bspace then begin if tspace < FMagnetBuffer then begin AddMagnetForm(AClient, Point(ClientBound.Left - ServerBound.Left, ClientBound.Top - ServerBound.Top)); OffsetRect(ServerBound, 0, -(ServerBound.Top - ClientBound.Bottom)); Result := True; end; end else begin if bspace < FMagnetBuffer then begin AddMagnetForm(AClient, Point(ClientBound.Left - ServerBound.Left, ClientBound.Top - ServerBound.Top)); OffsetRect(ServerBound, 0, -(ServerBound.Bottom - ClientBound.Top)); Result := True; end; end; end; end; procedure TCustomMagnetForm.ProcessServerMove; var i: Integer; p: TPoint; begin Inherited; if Self = Application.MainForm then begin if FMagnetClientList <> nil then for i := 0 to FMagnetClientList.Count - 1 do begin if FMagnetClientList[i].FEnableMagnetMoveClient then begin p := FMagnetClientList[i].FMagnetPosOffset; FMagnetClientList[i].SetBounds(Left + p.X, Top + p.Y, FMagnetClientList[i].Width, FMagnetClientList[i].Height); end; end; end; end; procedure TCustomMagnetForm.AddMagnetForm(AForm: TCustomMagnetForm; Value: TPoint); var Index: Integer; begin if (Application.MainForm <> nil) and (Application.MainForm is TCustomMagnetForm) then with TCustomMagnetForm(Application.MainForm) do if FMagnetClientList <> nil then begin AForm.FMagnetPosOffset := Value; Index := FMagnetClientList.IndexOf(AForm); if Index < 0 then begin Index := FMagnetClientList.Add(AForm); end; end; end; procedure TCustomMagnetForm.RemoveMagnetForm(AForm: TCustomMagnetForm); begin AForm.FEnableMagnetMoveClient := False; if (Application.MainForm <> nil) and (Application.MainForm is TCustomMagnetForm) then with TCustomMagnetForm(Application.MainForm) do if FMagnetClientList <> nil then begin if FMagnetClientList.IndexOf(AForm) >= 0 then begin FMagnetClientList.Remove(AForm); end; end; end; procedure TCustomMagnetForm.WMMove(var Message: TWMMove); begin ProcessServerMove; end; procedure TCustomMagnetForm.WMMoving(var Message: TWMMoving); begin ProcessServerMove; end; procedure TCustomMagnetForm.WMSysCommand(var Message: TWMSysCommand); procedure SetAllClientEnableMove(); var i: Integer; begin Inherited; if Self = Application.MainForm then begin if FMagnetClientList <> nil then for i := 0 to FMagnetClientList.Count - 1 do begin FMagnetClientList[i].FEnableMagnetMoveClient := True; end; end; end; begin Inherited; if (Message.CmdType and SC_MOVE) = SC_MOVE then begin SetAllClientEnableMove(); end; end; procedure TCustomMagnetForm.WMWindowPosChanging(var Message : TWMWindowPosChanging); var ServerBound, ClientBound: TRect; lspace, rspace, tspace, bspace: Integer; MainForm: TCustomMagnetForm; oBound: TRect; i: Integer; begin inherited; if (Message.WindowPos^.flags and SWP_NOMOVE) = SWP_NOMOVE then begin Exit; end; if (Application.MainForm = nil) or (not(Application.MainForm is TCustomMagnetForm)) then Exit; if (Application.MainForm = Self) then begin ServerBound := Rect(Message.WindowPos^.X, Message.WindowPos^.Y, Message.WindowPos^.X + Message.WindowPos^.cx, Message.WindowPos^.Y + Message.WindowPos^.cy); for i := 0 to Screen.FormCount - 1 do begin if (Screen.Forms[i] <> Self) and (Screen.Forms[i] is TCustomMagnetForm) and ((FMagnetClientList.IndexOf(TCustomMagnetForm(Screen.Forms[i])) < 0) or (not TCustomMagnetForm(Screen.Forms[i]) .FEnableMagnetMoveClient)) then begin ClientBound := Screen.Forms[i].BoundsRect; TCustomMagnetForm(Screen.Forms[i]).FEnableMagnetMoveClient := False; if ProcessServer(ServerBound, ClientBound, TCustomMagnetForm(Screen.Forms[i])) then begin Message.WindowPos^.X := ServerBound.Left; Message.WindowPos^.Y := ServerBound.Top; Message.WindowPos^.cx := ServerBound.Right - ServerBound.Left; Message.WindowPos^.cy := ServerBound.Bottom - ServerBound.Top; break; end; end; end; end else begin MainForm := TCustomMagnetForm(Application.MainForm); MainForm.RemoveMagnetForm(Self); ServerBound := Application.MainForm.BoundsRect; ClientBound := Rect(Message.WindowPos^.X, Message.WindowPos^.Y, Message.WindowPos^.X + Message.WindowPos^.cx, Message.WindowPos^.Y + Message.WindowPos^.cy); ProcessClient(ServerBound, ClientBound); Message.WindowPos^.X := ClientBound.Left; Message.WindowPos^.Y := ClientBound.Top; Message.WindowPos^.cx := ClientBound.Right - ClientBound.Left; Message.WindowPos^.cy := ClientBound.Bottom - ClientBound.Top; FEnableMagnetMoveClient := True; end; end; initialization TCustomMagnetForm.FMagnetBuffer := 10; finalization end.
绘制圆角矩形的窗体
制作圆角矩形的窗体: procedure TPortForm.FormCreate(Sender: Tobject); var hr :thandle; begin hr:=createroundrectrgn(0,0,width,height,20,20); setwindowrgn(handle,hr,true); end; 如果不要窗体外框,则使用: 01.procedure TPortForm.FormCreate(Sender: Tobject); 02.var hr :thandle; 03.begin 04.hr:=createroundrectrgn(1,1,width-2,height-2,20,20); 05.setwindowrgn(handle,hr,true); 06.end; 由于第一段代码做出来的窗口,圆角部份会没有边框,使用下面的代码做出边框: 01.procedure TForm1.FormPaint(Sender: TObject); 02.var 03.DC: HDC; 04.Pen: HPen; 05.OldPen: HPen; 06.OldBrush: HBrush; 07.begin 08.DC := GetWindowDC(Handle); 09.Pen := CreatePen(PS_SOLID, 1, clGray); 10.OldPen := SelectObject(DC, Pen); //载入自定义的画笔,保存原画笔 11.OldBrush := SelectObject(DC, GetStockObject(NULL_BRUSH));//载入空画刷,保存原画刷 12.RoundRect(DC, 0, 0, Width-1, Height-1,21,21); //画边框 13.SelectObject(DC,OldBrush);//载入原画刷 14.SelectObject(DC,OldPen); // 载入原画笔 15.DeleteObject(Pen); 16.ReleaseDC(Handle, DC); 17.end;
Delphi做异型窗体PNG透明
unit UnitYXForm; interface uses Windows, Forms, Classes, Graphics; //从文件加载PNG procedure YXForm_FromFile(AForm : TForm; AFileName : String); //从资源加载PNG procedure YXForm_FromResource(AForm : TForm; ResName : String; ResType : PWideChar; Instance : HINST = 0); //从图像对象加载 procedure YXForm_FromGraphic(AForm : TForm; AGraphic : TGraphic); implementation procedure YXForm_FromFile(AForm : TForm; AFileName : String); var wic : TWICImage; begin wic := TWICImage.Create; wic.LoadFromFile(AFileName); YXForm_FromGraphic(AForm, wic); wic.Free; end; procedure YXForm_FromResource(AForm : TForm; ResName : String;ResType : PWideChar; Instance : HINST); var wic : TWICImage; r : TResourceStream; begin if Instance = 0 then Instance := HInstance; r := TResourceStream.Create(Instance, ResName, ResType); wic := TWICImage.Create; wic.LoadFromStream(r); YXForm_FromGraphic(AForm, wic); wic.Free; r.Free; end; procedure YXForm_FromGraphic(AForm : TForm; AGraphic : TGraphic); var ptDst, ptSrc: TPoint; Size: TSize; BlendFunction: TBlendFunction; bmp : TBitmap; begin bmp := TBitmap.Create; bmp.Assign(AGraphic); ptDst := Point(AForm.Left, AForm.Top); ptSrc := Point(0, 0); Size.cx := AGraphic.Width; Size.cy := AGraphic.Height; BlendFunction.BlendOp := AC_SRC_OVER; BlendFunction.BlendFlags := 0; BlendFunction.SourceConstantAlpha := $FF; // 透明度 BlendFunction.AlphaFormat := AC_SRC_ALPHA; SetWindowLong(AForm.Handle, GWL_EXSTYLE, GetWindowLong(AForm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED); UpdateLayeredWindow(AForm.Handle, AForm.Canvas.Handle, @ptDst, @Size, bmp.Canvas.Handle, @ptSrc, 0, @BlendFunction, ULW_ALPHA); bmp.Free(); end; end. 想要用的时候很简单,举个例子: ff := TForm2.Create(Self); YXForm_FromFile(ff, 'c:\a.png'); ff.Show; 实现动画也很容易.只要不停地YXForm_FromFile(ff, 'c:\a.png');调用一套动作PNG就可以了.
delphi 半透明窗体类
{******************************************************************************* 半透明窗体控件 版本: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 窗体全透明,但窗体上的控件不透明
//窗体全透明,但窗体上的控件不透明 procedure TForm1.Button1Click(Sender: TObject); Var frmRegion, tempRegion: HRGN; i: Integer; Arect: TRect; Begin frmRegion := 0; For I:= 0 To ControlCount - 1 Do Begin aRect := Controls[i].BoundsRect; OffsetRect( aRect, clientorigin.x - left, clientorigin.y - top ); tempRegion := CreateRectRgnIndirect( aRect ); If frmRegion = 0 Then frmRegion := tempRegion Else Begin CombineRgn( frmRegion, frmRegion, tempRegion, RGN_OR ); DeleteObject( tempRegion ); End; End; tempregion := CreateRectRgn( 0, 0, Width, GetSystemMetrics( SM_CYCAPTION )+ GetSystemMetrics( SM_CYSIZEFRAME )+ GetSystemMetrics( SM_CYMENU ) * Ord(Menu <> Nil)); CombineRgn( frmRegion, frmRegion, tempRegion, RGN_OR ); DeleteObject( tempRegion ); SetWindowRgn( handle, frmRegion, true ); End;
delphi 透明
procedure TForm1.FormCreate(Sender: TObject); var rgn:HRGN; begin Self.Color := clRed; BeginPath(Canvas.Handle); SetBkMode(Canvas.Handle,TRANSPARENT ); Canvas.Font.Name:='宋体'; Canvas.Font.Size:=100; Canvas.TextOut(20,20,'My Baby?'); EndPath(Canvas.Handle); rgn:= PathToRegion(Canvas.Handle); SetWindowRgn(Handle,rgn,true); end; <pre class="delphi" name="code">unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; const {An array of points for the star region} RgnPoints:array[1..10] of TPoint= ((x:203;y:22),(x:157;y:168),(x:3;y:168),(x:128;y:257), (x:81;y:402),(x:203;y:334),(x:325;y:422),(x:278;y:257), (x:402;y:168),(x:249;y:168));//确定顶点 LinePoints:array[1..11] of Tpoint= ((x:199;y:0),(x:154;y:146),(x:2;y:146),(x:127;y:235), (x:79;y:377),(x:198;y:308),(x:320;Y:396),(x:272;y:234), (x:396;y:146),(x:244;y:146),(x:199;Y:0)); implementation {$R *.dfm} procedure TForm1.FormCreate(Sender: TObject); var Rgn:HRGN; begin Setwindowpos(Form1.Handle,HWND_TOPMOST,Form1.Left,form1.Top,Form1.Width,Form1.Height,0); Rgn:=CreatepolygonRgn(Rgnpoints,High(RgnPoints),ALTERNATE); SetWindowRgn(Handle,rgn,True); Form1.color:=clgreen; end; end. </pre><pre class="delphi" name="code">以下是用Api实现透明窗体的代码,最的一次第三个参数为透明的程度,范围为0~255,0为完全透明,255完全不透明.具体可参考 SetWindowLong(self.Handle,GWL_EXSTYLE, GetWindowLong(Self.Handle,GWL_EXSTYLE) xor $80000); SetLayeredWindowAttributes(Self.Handle,0,100,LWA_ALPHA); </pre><br> <br> <pre></pre> <pre></pre>
半透明窗体
unit xDrawForm; interface uses Windows, Messages, SysUtils, Classes, Controls, Forms, Menus, Graphics,GDIPOBJ,GDIPAPI,GDIPUTIL; type TwwGDIImage = class public n_Pos_X : Integer; n_Pos_Y : Integer; n_Width : Integer; n_Height : Integer; GPImageNormal : TGPImage; procedure CreateImageNormal(wsFileName: WideString;nPosX,nPosY,nW,nH:Integer); end; TwwGDIButton = class(TwwGDIImage) public GPImageHot : TGPImage; GPImageDown : TGPImage; end; TwwCanvas = class(TObject) private m_hdcMemory: HDC; hdcScreen: HDC; hBMP: HBITMAP; m_Blend: BLENDFUNCTION; // 事件 FGPGraph: TGPGraphics; FOnDrawImage: TNotifyEvent; procedure BeginDraw(); // 绘图前置工作 procedure EndDraw(Handle:THandle); // 绘图收尾工作 public sizeWindow: SIZE; ptSrc: TPOINT; n_Handle : THandle; procedure RePaint(h:THandle); procedure InitCanvas(nx,ny:Integer); procedure wwDrawImage(wwGDIImage :TwwGDIImage); property GPGraph: TGPGraphics read FGPGraph write FGPGraph; property OnDrawImage: TNotifyEvent read FOnDrawImage write FOnDrawImage; end; implementation { TwwCanvas } procedure TwwCanvas.BeginDraw; begin // 获取桌面屏幕设备 hdcScreen := GetDC(0); // 创建一个与指定设备兼容的内存设备上下文环境(DC) m_hdcMemory := CreateCompatibleDC(hdcScreen); // 创建与指定的设备环境相关的设备兼容的位图 hBMP := CreateCompatibleBitmap(hdcScreen, sizeWindow.cx, sizeWindow.cy ); // 选择一对象到指定的设备上下文环境中,该新对象替换先前的相同类型的对象 SelectObject(m_hdcMemory, hBMP); // 创建画布 GPGraph := TGPGraphics.Create(m_hdcMemory); end; procedure TwwCanvas.wwDrawImage(wwGDIImage: TwwGDIImage); begin GPGraph.DrawImage( wwGDIImage.GPImageNormal, wwGDIImage.n_Pos_X, wwGDIImage.n_Pos_Y, wwGDIImage.n_Width, wwGDIImage.n_Height) end; procedure TwwCanvas.EndDraw(Handle:THandle); begin // 设置窗体风格 SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED); // 执行透明混合 UpdateLayeredWindow(Handle, hdcScreen, nil,@sizeWindow, m_hdcMemory, @ptSrc, 0, @m_Blend, ULW_ALPHA); // 设置窗体位置 SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); // 各种释放就对了.. 不然画起来会糊 GPGraph.ReleaseHDC(m_hdcMemory); ReleaseDC(0, hdcScreen); hdcScreen := 0; DeleteObject(hBMP); DeleteDC(m_hdcMemory); m_hdcMemory := 0; GPGraph.Free; end; procedure TwwCanvas.RePaint(h:THandle); begin if Assigned(FOnDrawImage) then begin BeginDraw(); FOnDrawImage(Self); EndDraw(h); end; end; procedure TwwCanvas.InitCanvas(nx, ny: Integer); begin m_Blend.BlendOp := AC_SRC_OVER; // the only BlendOp defined in Windows 2000 m_Blend.BlendFlags := 0; // Must be zero m_Blend.AlphaFormat := AC_SRC_ALPHA; //This flag is set when the bitmap has an Alpha channel m_Blend.SourceConstantAlpha := 255; sizeWindow.cx := nx; sizeWindow.cy := ny; ptSrc := Point(0,0); end; { TwwGDIImage } procedure TwwGDIImage.CreateImageNormal(wsFileName: WideString;nPosX,nPosY,nW,nH:Integer); begin Self.GPImageNormal := TGPImage.Create(wsFileName); Self.n_Pos_X := nPosX; Self.n_Pos_Y := nPosY; Self.n_Width := nW; Self.n_Height:= nH; end; end. unit uMainForm; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, GDIPOBJ,GDIPAPI,GDIPUTIL; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormShow(Sender: TObject); private { Private declarations } public procedure DrawImage(Sender: TObject); { Public declarations } end; var Form1: TForm1; implementation uses xDrawForm; var wwCanvas : TwwCanvas = nil; img_BackGround: TwwGDIImage= nil; // 背景图 // img_ProgressBar1: TwwGDIImage= nil; // 上滚动条 // img_ProgressBar2: TwwGDIImage= nil; // 下滚动条 // img_Lighting: TwwGDIImage= nil; // 闪光点 {$R *.dfm} procedure TForm1.DrawImage(Sender: TObject); begin TwwCanvas(Sender).wwDrawImage(img_BackGround); end; procedure TForm1.FormCreate(Sender: TObject); begin DoubleBuffered := True; BorderStyle := bsNone; wwCanvas := TwwCanvas.Create(); wwCanvas.InitCanvas(872,690); wwCanvas.OnDrawImage := Self.DrawImage; img_BackGround := TwwGDIImage.Create(); img_BackGround.CreateImageNormal('BackGround.png',0,0,872,690); end; procedure TForm1.FormShow(Sender: TObject); begin wwCanvas.RePaint(Self.Handle); end; end.
窗体嵌入桌面
窗体最前面的显示方式: procedure Createparams(var params: TCreateParams);override; procedure Createparams(var params: TCreateParams); begin inherited CreateParams(Params); with params do begin Style:=WS_POPUP; //ExStyle := WS_EX_TOPMOST OR WS_EX_ACCEPTFILES or WS_DLGFRAME; ExStyle := WS_EX_TOOLWINDOW or WS_EX_TOPMOST or WS_EX_NOACTIVATE or WS_EX_WINDOWEDGE; WndParent :=GetDesktopwindow; //确实可以使用之为最前面 end; end; 窗体贴在桌面的方法: procedure WndProc(var Message: TMessage); override; procedure FormCreate(Sender: TObject); begin windows.SetParent(Self.Handle,FindWindowEx(FindWindow('Progman',nil),0,'shelldll_defview',nil));//将窗口设置为屏幕的子窗口 //以下显示桌面 keybd_event(91,0,0,0); keybd_event(77,0,0,0); keybd_event(77,0,KEYEVENTF_KEYUP,0); keybd_event(91,0,KEYEVENTF_KEYUP,0); end; procedure WndProc(var Message: TMessage); begin if not ( (Message.Msg=WM_SYSCOMMAND) AND (Message.WParam=SC_MINIMIZE) )then inherited WndProc(Message);//最小化无效 end;
使用PNG实现半透明的窗体
Delphi中标准控件是不支持png图片的,据说从Window2000后增加gdiplus.dll库处理更多的gdi图像,其中包括png。 关键的几个api GdipCreateBitmapFromFile(),从文件载入图像(不单只Bitmap) GdipCreateBitmapFromStreamICM(),从流中入图像 GdipCreateHBITMAPFromBitmap(),获取图像的位图 GdipDisposeImage(),释放图像资源 开始直接调用GdipCreateBitmapFromFile没有成功,返回18的错误 查一下资料这个错误是:“GdiplusNotInitialized” 看来必须的初始化gdiplus。 网上找到一套“TGPBitmap”相关的组件,封装了gdiplus的调用。可以参考其中的代码。 png载入后,再取出其位图。特别注意,这个位图是32位的。包括了R、G、B、Alpha四个色值,其中Alpha就是透明度。UpdateLayeredWindow()API函数可以支持Alpha风格。 如何从流中载入?如何将VCL的流处理成IStream?看看代码吧。 效果图: cj7.JPG 准备一张Png图片,编写rc文件,然后加入到工程中。 代码: CJ7.rc Png_Cj7 PNG "CJ7.png" CJ7Unit.pas unit CJ7Unit; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs; type TFormCJ7 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private { Private declarations } public { Public declarations } end; var FormCJ7: TFormCJ7; implementation {$R *.dfm} uses ActiveX; type DebugEventLevel = ( DebugEventLevelFatal, DebugEventLevelWarning ); TDebugEventLevel = DebugEventLevel; DebugEventProc = procedure(level: DebugEventLevel; message: PChar); stdcall; GdiplusStartupInput = packed record GdiplusVersion: Cardinal; DebugEventCallback: DebugEventProc; SuppressBackgroundThread: BOOL; SuppressExternalCodecs: BOOL; end; TGdiplusStartupInput = GdiplusStartupInput; PGdiplusStartupInput = ^TGdiplusStartupInput; NotificationHookProc = function(out token: ULONG): Integer; stdcall; NotificationUnhookProc = procedure(token: ULONG); stdcall; GdiplusStartupOutput = packed record NotificationHook : NotificationHookProc; NotificationUnhook: NotificationUnhookProc; end; TGdiplusStartupOutput = GdiplusStartupOutput; PGdiplusStartupOutput = ^TGdiplusStartupOutput; function GdipCreateHBITMAPFromBitmap(bitmap: THandle; out hbmReturn: HBITMAP; background: Longword): Integer; stdcall; external 'gdiplus.dll'; function GdipCreateBitmapFromFile(filename: PWChar; out bitmap: THandle): Integer; stdcall; external 'gdiplus.dll'; function GdipCreateBitmapFromStreamICM(stream: ISTREAM; out bitmap: THandle): Integer; stdcall; external 'gdiplus.dll'; function GdipDisposeImage(image: THandle): Integer; stdcall; stdcall; external 'gdiplus.dll'; function GdiplusStartup(out token: ULONG; input: PGdiplusStartupInput; output: PGdiplusStartupOutput): Integer; stdcall; external 'gdiplus.dll'; procedure GdiplusShutdown(token: ULONG); stdcall; external 'gdiplus.dll'; procedure TFormCJ7.FormCreate(Sender: TObject); var vGdip: THandle; vBitmap: HBITMAP; vOldBitmap: HBITMAP; vPoint1, vPoint2: TPoint; vSize: TSize; vBlendFunction: TBlendFunction; vDC: HDC; vBitmapInfo: TBitmapInfoHeader; vDIBSection: TDIBSection; vBuffer: PChar; vStream: IStream; vGlobal: THandle; begin SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED); ///Begin 从资源中载入 with TResourceStream.Create(HInstance, 'Png_Cj7', 'PNG') do try vGlobal := GlobalAlloc(GHND, Size); if vGlobal = 0 then Exit; vBuffer := GlobalLock(vGlobal); if not Assigned(vBuffer) then Exit; try Read(vBuffer^, Size); finally GlobalUnlock(vGdip); end; if CreateStreamOnHGlobal(vGlobal, False, vStream) <> S_OK then Exit; if GdipCreateBitmapFromStreamICM(vStream, vGdip) <> S_OK then Exit; GlobalFree(vGlobal); finally Free; end; ///End 从资源中载入 if GdipCreateHBITMAPFromBitmap(vGdip, vBitmap, 0) <> S_OK then Exit; vBitmapInfo.biSize := SizeOf(vBitmapInfo); GetObject(vBitmap, SizeOf(vDIBSection), @vDIBSection); vPoint1 := Point(Left, Top); vPoint2 := Point(0, 0); vSize.cx := vDIBSection.dsBm.bmWidth; vSize.cy := vDIBSection.dsBm.bmHeight; vBlendFunction.BlendOp := AC_SRC_OVER; vBlendFunction.BlendFlags := 0; vBlendFunction.SourceConstantAlpha := $FF; // 透明度 vBlendFunction.AlphaFormat := AC_SRC_ALPHA; //同上 vDC := CreateCompatibleDC(Canvas.Handle); vOldBitmap := SelectObject(vDC, vBitmap); UpdateLayeredWindow(Handle, Canvas.Handle, @vPoint1, @vSize, vDC, @vPoint2, 0, @vBlendFunction, ULW_ALPHA); SelectObject(vDC, vOldBitmap); DeleteDC(vDC); DeleteObject(vBitmap); GdipDisposeImage(vGdip); end; procedure TFormCJ7.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin ReleaseCapture; Perform(WM_SYSCOMMAND, SC_MOVE or HTCLIENT, 0); // 拖动 end; var vStartupInput: TGDIPlusStartupInput; vToken: ULONG; initialization vStartupInput.DebugEventCallback := nil; vStartupInput.SuppressBackgroundThread := False; vStartupInput.SuppressExternalCodecs := False; vStartupInput.GdiplusVersion := 1; GdiplusStartup(vToken, @vStartupInput, nil); finalization GdiplusShutdown(vToken); end. 想了解gdi+的资料可以参考: http://msdn2.microsoft.com/en-us/library/ms533798.aspx
异形窗体
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, u360StyleButton,ActiveX; type TForm1 = class(TForm) Btn360Style1: TBtn360Style; Button1: TButton; procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation uses GDIPAPI, GDIPOBJ; {$R *.dfm} {$R '.\SkinRes.RES'} procedure TForm1.FormCreate(Sender: TObject); var vGdip: THandle; vBitmap: HBITMAP; vOldBitmap: HBITMAP; vPoint1, vPoint2: TPoint; vSize: TSize; vBlendFunction: TBlendFunction; vDC: HDC; vBitmapInfo: TBitmapInfoHeader; vDIBSection: TDIBSection; vBuffer: PChar; vStream: IStream; vGlobal: HGLOBAL; begin {SetWindowLong(Handle,GWL_EXSTYLE, getwindowlong(handle,GWL_EXSTYLE) and (not WS_EX_APPWINDOW) or WS_EX_TOOLWINDOW or WS_EX_LAYERED ); //从资源中载入 with TResourceStream.Create(HInstance, 'Module_briangle_png', 'skin') do try vGlobal := GlobalAlloc(GHND, Size); if vGlobal = 0 then Exit; vBuffer := GlobalLock(vGlobal); if not Assigned(vBuffer) then Exit; try Read(vBuffer^, Size); finally GlobalUnlock(vGdip); end; if CreateStreamOnHGlobal(vGlobal, False, vStream) <> S_OK then Exit; if GdipCreateBitmapFromStreamICM(vStream,pointer( vGdip)) <> OK then Exit; GlobalFree(vGlobal); finally Free; end; if GdipCreateHBITMAPFromBitmap(pointer(vGdip), vBitmap, 0) <> OK then Exit; vBitmapInfo.biSize := SizeOf(vBitmapInfo); GetObject(vBitmap, SizeOf(vDIBSection), @vDIBSection); vPoint1 := Point(Left, Top); vPoint2 := Point(0, 0); vSize.cx := vDIBSection.dsBm.bmWidth; vSize.cy := vDIBSection.dsBm.bmHeight; vBlendFunction.BlendOp := AC_SRC_OVER; vBlendFunction.BlendFlags := 0; vBlendFunction.SourceConstantAlpha := $FF; // 透明度 vBlendFunction.AlphaFormat := AC_SRC_ALPHA; //同上 vDC := CreateCompatibleDC(Canvas.Handle); vOldBitmap := SelectObject(vDC, vBitmap); UpdateLayeredWindow(Handle, Canvas.Handle, @vPoint1, @vSize, vDC, @vPoint2, 0, @vBlendFunction, ULW_ALPHA); SelectObject(vDC, vOldBitmap); DeleteDC(vDC); DeleteObject(vBitmap); GdipDisposeImage(Pointer(vGdip));} end; end.
异形窗口 png
{*******************************************************} { } { 异形窗口 } { } { 2009.12.4 王 锐 } { } {*******************************************************} unit UnitYXForm; interface uses Windows, Forms, Classes, Graphics; //从文件加载PNG procedure YXForm_FromFile(AForm : TForm; AFileName : String); //从资源加载PNG procedure YXForm_FromResource(AForm : TForm; ResName : String; ResType : PWideChar; Instance : HINST = 0); //从图像对象加载 procedure YXForm_FromGraphic(AForm : TForm; AGraphic : TGraphic); implementation procedure YXForm_FromFile(AForm : TForm; AFileName : String); var wic : TWICImage; begin wic := TWICImage.Create; wic.LoadFromFile(AFileName); YXForm_FromGraphic(AForm, wic); wic.Free; end; procedure YXForm_FromResource(AForm : TForm; ResName : String;ResType : PWideChar; Instance : HINST); var wic : TWICImage; r : TResourceStream; begin if Instance = 0 then Instance := HInstance; r := TResourceStream.Create(Instance, ResName, ResType); wic := TWICImage.Create; wic.LoadFromStream(r); YXForm_FromGraphic(AForm, wic); wic.Free; r.Free; end; procedure YXForm_FromGraphic(AForm : TForm; AGraphic : TGraphic); var ptDst, ptSrc: TPoint; Size: TSize; BlendFunction: TBlendFunction; bmp : TBitmap; begin bmp := TBitmap.Create; bmp.Assign(AGraphic); ptDst := Point(AForm.Left, AForm.Top); ptSrc := Point(0, 0); Size.cx := AGraphic.Width; Size.cy := AGraphic.Height; BlendFunction.BlendOp := AC_SRC_OVER; BlendFunction.BlendFlags := 0; BlendFunction.SourceConstantAlpha := $FF; // 透明度 BlendFunction.AlphaFormat := AC_SRC_ALPHA; SetWindowLong(AForm.Handle, GWL_EXSTYLE, GetWindowLong(AForm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED); UpdateLayeredWindow(AForm.Handle, AForm.Canvas.Handle, @ptDst, @Size, bmp.Canvas.Handle, @ptSrc, 0, @BlendFunction, ULW_ALPHA); bmp.Free(); end; end.