Delphi基础:Window 消息大全使用详解
delphi 透明控件小结
.
2012-04-02 21:13319人阅读评论(0)收藏举报
将一个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
浙公网安备 33010602011771号