delphi 透明控件小结

将一个FORM变成透明的实质性手段就是拦截CMEraseBkgnd消息。

unit Utransform; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; type TForm1 = class(TForm)

private { Private declarations }

public { Public declarations }

PROCEDURE CMEraseBkgnd(var Message:TWMEraseBkgnd);Message WM_ERASEBKGND;

end;

var Form1: TForm1;

implementation

{$R *.DFM}

PROCEDURE Tform1.CMEraseBkgnd(var Message:TWMEraseBkgnd);

BEGIN

brush.style:=bsClear;

Inherited;

END;

end.

//////////////////////////////////////

procedure TForm1.FormCreate(Sender: TObject);

begin

Form1.Brush.Style := bsClear;

Form1.BorderStyle := bsNone

end;

procedure TForm1.BitBtn1Click(Sender: TObject);

begin

Application.Terminate;

end;

/////////////////////////////////////////////

用透明的控件呗. 一般继承自TGraphicControl的

(就是那些没有handle属性, 不能有focus的控件, 如image)

都有Transparent属性. 对TWinControl类的控件, 要实现透明只要完成以下

四步基本上就成了.

1.在Create中设定ControlStyle :=

ControlStyle - [csOpaque];)

2. override 它的CreateParams方法, exstyle 里加上WS_EX_TRANSPARENT.

3. 修改它的parent的window style, 去掉WS_CLIPCHILDREN.

inherited CreateParams(Params);

with Params do

begin

{ 完全重画 }

Style := Style and not WS_CLIPCHILDREN;

Style := Style and not WS_CLIPSIBLINGS;

{ 增加透明 }

ExStyle := ExStyle or WS_EX_TRANSPARENT;

end;

4. 截获WM_ERASEBKGND, 什么都不做直接返回1.(不搽除背景)

一般有上面3步能成. 有些控件比如TPanel, 在它的paint中用了fillrect, 所以要实现透明的话还要override 它的paint方法,自己画.

按钮透明需要进一步处理.

createparams里加上style := style or BS_OWNERDRAW;

然后在WM_DRAWITEM中自己画吧

unit TransButton;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TTransButton = class(TButton)

private

FTransparent : Boolean;

procedure SetTransparent(Value: Boolean);

procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;

protected

procedure CreateParams(var Params: TCreateParams); override;

procedure SetParent(AParent: TWinControl); override;

published

property Transparent: Boolean read FTransparent write SetTransparent;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('CX Lib', [TTransButton]);

end;

procedure TTransButton.SetTransparent(Value: Boolean);

begin

if ftransparent <> value then

begin

ftransparent := value;

if value then

controlstyle := controlstyle - [csOpaque]

else

controlstyle := controlstyle + [csOpaque];

invalidate;

end;

end;

procedure TTransButton.WMEraseBkgnd(var Msg: TMessage);

var

br: HBRUSH;

begin

if ftransparent then

msg.result := 1

else

inherited;

end;

procedure TTransButton.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

params.exstyle := params.exstyle or WS_EX_TRANSPARENT;

end;

procedure TTransButton.SetParent(AParent: TWinControl);

begin

inherited SetParent(AParent);

if (aparent <> nil) and aparent.HandleAllocated

and (GetWindowLong(aparent.Handle, GWL_STYLE) or WS_CLIPCHILDREN <> 0) then

SetWindowLong(aparent.handle, GWL_STYLE, GetWindowLong(aparent.Handle, GWL_STYLE)

and not WS_CLIPCHILDREN);

end;

end.

//////////////////////////////////////////////////////////////

透明的TPanel

type

TPanelBorder = set of (pbInnerRaised, pbInnerSunk, pbOuterRaised, pbOuterSunk);

TTrPanel = class(TCustomPanel)

private

FTransparentRate : Integer; // 透明度

FBkGnd : TBitmap; // 背景buffer

procedure SetTransparentRate(value: Integer);

procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;

protected

procedure BuildBkgnd; virtual; // 生成半透明的背景

procedure SetParent(AParent : TWinControl); override;

procedure CreateParams(var Params: TCreateParams); override;

procedure Paint; override;

public

Constructor Create(AOwner: TComponent); override;

Destructor Destroy; override;

procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; // resize or move

procedure Invalidate; override;

procedure InvalidateA; virtual;

published

property TransparentRate: Integer read FTransparentRate write SetTransparentRate;

property ......

........ // 可以抄TPanel里面的

end;

procedure Register;

implimentation

procedure Register;

begin

RegisterComponent('Samples', [TTrPanel]);

end;

procedure TTrPanel.SetTransparentRate(value: Integer);

begin

if (value <0) or (value > 100) then exit;

if value <> FTransparentRate then

begin

FTransparentRate := value;

Invalidate;

end;

end;

procedure TTrPanel.WMEraseBkgnd(var Msg: TMessage);

begin

Msg.Result := 1;

end;

procedure TTrPanel.SetParent(AParent: TWinControl);

begin

inherited SetParent(AParent);

if (AParent <> nil) and AParent.HandleAllocated

and (GetWindowLong(AParent.Handle, GWL_STYLE) and WS_CLIPCHILDREN <> 0)

then

SetWindowLong(AParent.Handle, GWL_STYLE,

GetWindowLong(AParent.Handle, GWL_STYLE)

and not WS_CLIPCHILDREN);

end;

procedure TTrPanel.CreateParams(.....);

begin

inherited CreateParams(Params);

params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;

end;

procedure TTrPanel.Paint;

begin

if not assigned(FBkgnd) then

BuildBkgnd;

bitblt(Canvas.handle, 0, 0, width, height, FBkgnd.Canvas.Handle, 0, 0, SRCCOPY);

........

........ // 画边框, 画caption等, 就不写了.

end;

type

T24Color = record

b, g, r: Byte;

end;

P24Color := ^T24Color;

procedure TTrPanel.BuildBkgnd;

var

p, p1: P24Color;

C : LongInt;

i, j: Integer;

begin

FBkgnd := TBitmap.Create;

FBkgnd.PixelFormat := pf24Bit;

FBkgnd.Width := Width;

FBkgnd.Height := Height;

if ftransparentrate > 0 then

begin

BitBlt(FBkgnd.Canvas.handle, 0, 0, Width, Height, Canvas.Handle, 0, 0, SRCCOPY);

if ftransparentrate < 100 then // 部分透明

begin

c := ColorToRGB(Color);

// 注意: ColorToRGB得到的颜色r, b位置与

// scanline中颜色顺序正好相反.

p1 := @c;

for i := 0 to FBkgnd.Height - 1 do

begin

p := FBkgnd.Scanline[i];

for j := 0 to FBkgnd.Width - 1 do

begin

p^.r := (p^.r * ftransparentrate + p1^.b * (100-ftransparentrate)) div 100;

p^.g := (p^.g * ftransparentrate + p1^.g * (100-ftransparentrate)) div 100;

p^.b := (p^.b * ftransparentrate + p1^.r * (100-ftransparentrate)) div 100;

p := pointer(integer(p)+3);

end;

end;

end;

end

else begin // 不透明

c := CreateSolidBrush(ColorToRGB(color));

FillRect(fFBkgnd.canvas.handle, c);

deleteobject(c);

end;

controlstyle := controlstyle + [csOpaque]; // 背景没有变化时的重画不会出现闪烁

end;

Constructor TTrPanel.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

fbkgnd := nil;

fTransparentRate := 0;

end;

Destructor TTrPanel.Destroy;

begin

if assigned(fbkgnd) then

fbkgnd.free;

inherited;

end;

procedure TTrPanel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);

begin

if ftransparentrate > 0 then // 移动时能获得正确的背景

invalidate;

inherited;

end;

procedure TTrPanel.Invalidate; // 刷新时重新计算背景

begin

if assigned(fbkgnd) then

begin

fbkgnd.free;

fbkgnd := nil;

controlstyle := constrolstyle - [csOpaque];

end;

inherited;

end;

procedure TTrPanel.InvalidateA; // 刷新时不重新计算背景(可以加快显示速度)

begin

inherited Invalidate;

end;

end.

//////////////////////////////////////////////

unit homepage_coolform;interfaceuses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls, Buttons;

type TForm1 = class(TForm)

procedure FormPaint(Sender: TObject);

procedure FormShow(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private { Private declarations }

public { Public declarations }

hbmp:integer;

end;

var Form1: TForm1;

implementation

{$R *.DFM}

function CopyScreenToBitmap(Rect:TREct):integer;

var

hScrDC, hMemDC, hBitmap, hOldBitmap:integer;

nX, nY, nX2, nY2: integer;

nWidth, nHeight:integer;

xScrn, yScrn:integer;

begin

if (IsRectEmpty(Rect)) then

begin

result:= 0;

exit;

end; // 获得屏幕缓冲区的句柄.

// a memory DC compatible to screen DC

hScrDC:= CreateDC('DISPLAY', pchar(0), pchar(0), PDeviceModeA(0));

hMemDC:= CreateCompatibleDC(hScrDC);

// get points of rectangle to grab

nX := rect.left;

nY := rect.top;

nX2 := rect.right;

nY2 := rect.bottom;

// get screen resolution

xScrn:= GetDeviceCaps(hScrDC, HORZRES);

yScrn := GetDeviceCaps(hScrDC, VERTRES);

//make sure bitmap rectangle is visible

if (nX <0) then

nX :="0;"

if (nY < 0) then

nY :="0;"

if (nX2> xScrn) then

nX2 := xScrn;

if (nY2 > yScrn) then

nY2 := yScrn;

nWidth := nX2 - nX;

nHeight := nY2 - nY;

// create a bitmap compatible with the screen DC

hBitmap := CreateCompatibleBitmap(hScrDC, nWidth, nHeight);

// select new bitmap into memory DC

hOldBitmap := SelectObject(hMemDC, hBitmap);

// bitblt screen DC to memory DC

BitBlt(hMemDC, 0, 0, nWidth, nHeight, hScrDC, nX, nY, SRCCOPY);

// select old bitmap back into memory DC and get handle to

// bitmap of the screen

hBitmap := SelectObject(hMemDC, hOldBitmap);

// clean up

DeleteDC(hScrDC);

DeleteDC(hMemDC);

result:= hBitmap;

end;

procedure TForm1.FormShow(Sender: TObject);

Var

rect:TRect;

p:TPoint;

begin

rect:=ClientRect;

p:=ClientOrigin;

rect.left:=p.x;

rect.top:=p.y;

rect.bottom:=rect.bottom+p.y;

rect.right:=rect.right+p.x;

hbmp:=copyScreenToBitmap(rect);

inherited;

end;

procedure TForm1.FormPaint(Sender: TObject);

var

bitmap:TBitmap;

rect:TRect;

begin

bitmap:=TBitmap.create;

bitmap.handle:=hbmp;

rect:=ClientRect;

canvas.draw(rect.left,rect.top,bitmap);

bitmap.handle:=0;

bitmap.free;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

DeleteObject(hbmp);

end;

end.

////////////////////////////////////////////

type

TBackgroundStyle = (bsOpaque, bsTransparent);

TCustomButtonPanel = class(TScrollBox)

private

FCanvas: TCanvas; { Need a Canvas }

protected

procedure WMSize(var Message: TWMSize); message WM_SIZE;

procedure WMPaint(var Message: TWMPaint); message WM_PAINT;

procedure WMMove(var Message: TWMMove); message WM_MOVE;

procedure CreateParams(var Params: TCreateParams); override;

procedure PaintWindow(DC: HDC); override;

procedure Paint; virtual;

procedure InvalidateFrame;

property BackgroundStyle: TBackgroundStyle

read FBackgroundStyle

write SetBackgroundStyle

default bsOpaque;

... other stuff snipped ...

public

constructor Create(AOwner: TComponent); override;

property Canvas: TCanvas read FCanvas;

... other stuff snipped ...

end;

... other code and stuff snipped ...

implementation

constructor TCustomButtonPanel.Create(AOwner: TComponent);

begin

FBackgroundStyle := bsOpaque;

inherited Create(AOwner);

ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,

csSetCaption, csOpaque, csDoubleClicks];

FCanvas := TControlCanvas.Create;

TControlCanvas(FCanvas).Control := Self;

end;

procedure TCustomButtonPanel.SetBackgroundStyle(Value:TBackgroundStyle);

begin

{ BackgroundStyle Set Property Handler }

if Value <> FBackgroundStyle then begin

FBackgroundStyle := Value;

RecreateWnd;

end;

end;

procedure TCustomButtonPanel.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

with Params do begin

if FBackgroundStyle = bsOpaque then

ExStyle := ExStyle and not Ws_Ex_Transparent

else

ExStyle := ExStyle or Ws_Ex_Transparent;

end;

end;

procedure TCustomButtonPanel.PaintWindow(DC: HDC);

begin

{ Setup the canvas and call the Paint routine }

FCanvas.Handle := DC;

try

Paint;

finally

FCanvas.Handle := 0;

end;

end;

procedure TCustomButtonPanel.Paint;

var

theRect: TRect;

begin

with canvas do

brush.Color := Self.Color;

theRect := GetClientRect;

if FBackgroundStyle = bsOpaque then

FillRect(theRect);

... other code and stuff snipped ...

end;

end;

procedure TCustomButtonPanel.InvalidateFrame;

var

R: TRect;

begin

{ Handle invalidation after move in designer }

R := BoundsRect;

InflateRect(R, 1, 1);

InvalidateRect(Parent.Handle, @R, True);

end;

procedure TCustomButtonPanel.WMMove(var Message: TWMMove);

begin

if (csDesigning in ComponentState) then

InvalidateFrame;

inherited;

end;

///////////////////////////////////////////////////

1. 使RichEdit的窗口透明. SetWindowLong(RichEdit.Handle, GWL_EXSTYLE, GetWindowLong(RichEdit.Handle,GWL_EXSTYLE) or WS_EX_TRANSPARENT);

2. 截获RichEdit的Wndproc, 处理以下消息:

CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC: 返回一个NullBrush的handle

(防止编辑状态时清除背景).

WM_ERASEBKGND: 什么都不做就返回1(防止窗口在刷新时清除背景)

欢迎转载，但请保留出处，本文章转自[华软源码]，原文链接：http://www.hur.cn/special/Delphitech/02607.htm