delphi 半透明窗体类

{*******************************************************************************

  半透明窗体控件

  版本：1.0

  功能说明 :

  1.支持颜色和图片半透明

  2.暂时只能手动指定背景图片

  3.可调透明度(0..255)

  4.可控制是否可移动窗体

  联系方式： Email:  [email protected]

*******************************************************************************}

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 :=  ;

  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, );

    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(,,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(,,FGpBitmap.Width,FGpBitmap.Height),,,FBmp.Width,FBmp.Height,utPixel);

      FreeAndNil(gd);

      FreeAndNil(FBmp);

    except

      Exit;

    end;

  end;

  hdcScreen := GetDC();

  m_hdcMemory := CreateCompatibleDC(hdcScreen);

  hBMP := CreateCompatibleBitmap(hdcScreen, FGpBitmap.Width, FGpBitmap.Height);

  SelectObject(m_hdcMemory, hBMP);

  GPGraph := TGPGraphics.Create(m_hdcMemory);

  try

    GPGraph.DrawImage(FGpBitmap, , , FGpBitmap.Width, FGpBitmap.Height);

    zsize.cx := FGpBitmap.Width;

    zsize.cy := FGpBitmap.Height;

    zpoint := Point(, );

    with zbf do

    begin

      BlendOp := AC_SRC_OVER;

      BlendFlags := ;

      SourceConstantAlpha := TransparentValue;

      AlphaFormat := AC_SRC_ALPHA;

    end;

    GetWindowRect(FOverlayerForm.Handle, WR);

    TopLeft := WR.TopLeft;

    UpdateLayeredWindow(FOverlayerForm.Handle, , @TopLeft, @zsize, GPGraph.GetHDC, @zpoint,, @zbf, );

  finally

    GPGraph.ReleaseHDC(m_hdcMemory);

    ReleaseDC(, 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.