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.