delphi 半透明窗体类

{*******************************************************************************  半透明窗体控件  版本：1.0  功能说明 :  1.支持颜色和图片半透明  2.暂时只能手动指定背景图片  3.可调透明度(0..255)  4.可控制是否可移动窗体   联系方式： Email:  [e-mail]*******************************************************************************}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.