散分！高手请进。Label及Panel透明度问题！
在界面设计中，可以拦截CMEraseBkgnd消息，促使生成事实不存在的窗体，在 Win2000 和 WinXP 中，用 SetLayeredWindowAttributes 产生半透明窗体，而用什么方法使得 Label 和 Panel 等也具有相同的效果？
------------------------
方法无限制，确实可行及得！
------------------------
问题点数：100、回复次数：11Top
1 楼cgh1970（聊天别找我）回复于 2003-02-02 06:49:35 得分 2
upTop
2 楼rouqing（*冰雨&双子座奇缘*）回复于 2003-02-02 15:17:52 得分 2
Label->Transparent=true???Top
3 楼gzllich（刚从泥坑里出来）回复于 2003-02-03 17:29:35 得分 2
同意楼上的，设置Label的Transparent属性为true,delphi本身的panel没有此属性，但1stclass的fcPanel却有此属性,可借来一用Top
4 楼ly_liuyang（Liu Yang LYSoft http://lysoft.7u7.net）回复于 2003-02-03 23:42:47 得分 43
//////////////////////////////////////////////////////////////
透明的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;
Top
5 楼ly_liuyang（Liu Yang LYSoft http://lysoft.7u7.net）回复于 2003-02-03 23:43:44 得分 43
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;
当然你还可以使用第三方组件的
/ by LY http://www.99898.com/www/lysoftTop
6 楼RobinChurchill（秋枫）回复于 2003-02-04 02:06:06 得分 0
Thanks ly_liuyang(Liu Yang) and ly_liuyang(Liu Yang).ly_liuyang(Liu Yang) your WebSit I had visit to and click the top banner to countenance your Web;and thanks everybody to answer the question.The question will have many answers.
所有参加者，都会得到分值；希望大家踊跃参加，只要达到可行问题解决方案，对于所有参与者都是一次学习与积累的机会，谢谢！Top
7 楼johnmack（爱若琴弦）回复于 2003-02-04 08:00:36 得分 2
学习！Top
8 楼cdimp（生鱼片）回复于 2003-02-04 08:28:49 得分 2
upTop
9 楼lxlsky（lxl）回复于 2003-02-06 22:43:43 得分 2
学习！Top
10 楼IceboundRock（）回复于 2003-02-06 23:01:45 得分 2
果然是高手啊，厉害，收藏……Top
11 楼RobinChurchill（秋枫）回复于 2003-02-08 06:28:40 得分 0
只适应于 Win 2000/XP 窗口透明，SetLayeredWindowAttributes 为 2000/XP 新增 API ：
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
const
WS_EX_LAYERED = $80000;
LWA_ALPHA = $2;
type
TForm1 = class(TForm)
Label1: TLabel;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
function SetLayeredWindowAttributes(hwnd:HWND; crKey:Longint; bAlpha:byte; dwFlags:longint ):longint;stdcall;external user32;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var
l:Longint;
begin
l :=getWindowLong(Handle, GWL_EXSTYLE);
l := l or WS_EX_LAYERED;
SetWindowLong (handle, GWL_EXSTYLE, l);
SetLayeredWindowAttributes (handle, 0, 180, LWA_ALPHA);
end;
end.
Top
相关问题
关键词
得分解答快速导航
相关链接
广告也精彩
反馈
