//透明Panel控件

unit TranPanel;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls; type TGlassStyle = (
gsBlackness, gsDstInvert, gsMergeCopy, gsMergePaint, gsNotSrcCopy,
gsNotSrcErase, gsPatCopy, gsPatInvert, gsPatPaint, gsSrcAnd,
gsSrcCopy, gsSrcErase, gsSrcInvert, gsSrcPaint, gsWhiteness); TGlass = class(TCustomControl) private FColor: TColor;
FStyle: TGlassStyle;
FOnPaint: TNotifyEvent;
procedure SetColor(Value: TColor);
procedure SetStyle(Value: TGlassStyle);
procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING; protected Buffer: TBitmap;
procedure CreateParams(var Params: TCreateParams); override;
procedure Paint; override;
procedure Resize; override; public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Canvas; published property Align;
property Anchors;
property AutoSize;
property BiDiMode;
property BorderWidth;
property Color: TColor read FColor write SetColor;
property Ctl3D;
property Enabled;
property Style: TGlassStyle read FStyle write SetStyle default gsSrcAnd;
property Visible;
property OnClick;
property OnDblClick;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
end; procedure Register; implementation procedure Register;
begin
RegisterComponents('Croco', [TGlass]);
end; function GlassStyleToInt(gs: TGlassStyle): LongInt;
begin
case gs of
gsBlackness : Result := cmBlackness;
gsDstInvert : Result := cmDstInvert;
gsMergeCopy : Result := cmMergeCopy;
gsMergePaint : Result := cmMergePaint;
gsNotSrcCopy : Result := cmNotSrcCopy;
gsNotSrcErase: Result := cmNotSrcErase;
gsPatCopy : Result := cmPatCopy;
gsPatInvert : Result := cmPatInvert;
gsPatPaint : Result := cmPatPaint;
gsSrcAnd : Result := cmSrcAnd;
gsSrcCopy : Result := cmSrcCopy;
gsSrcErase : Result := cmSrcErase;
gsSrcInvert : Result := cmSrcInvert;
gsSrcPaint : Result := cmSrcPaint;
gsWhiteness : Result := cmWhiteness;
else Assert(True, 'Error parameter in function GlassStyleToInt');
end;
end; constructor TGlass.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Buffer := TBitmap.Create;
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csDoubleClicks, csReplicatable];
Width := ;
Height := ;
FStyle := gsSrcAnd;
ParentCtl3d := False;
Ctl3D := False;
ParentColor := False;
FColor := clWhite;
end; destructor TGlass.Destroy;
begin
Buffer.Free;
inherited Destroy;
end; procedure TGlass.Paint;
var
R: TRect;
rop: LongInt;
begin
R := Rect(, , Width, Height);
Buffer.Width := Width;
Buffer.Height := Height;
Buffer.Canvas.Brush.Style := bsSolid;
Buffer.Canvas.Brush.Color := FColor;
Buffer.Canvas.FillRect(Rect(, , Width, Height));
rop := GlassStyleToInt(FStyle);
StretchBlt(Buffer.Canvas.Handle, , , Width, Height,
Canvas.Handle, , , Width, Height, rop);
if Ctl3D then DrawEdge(Buffer.Canvas.Handle, R, BDR_RAISEDINNER, BF_RECT);
Buffer.Canvas.Pen.Mode := pmCopy;
Buffer.Canvas.Pen.Style := psSolid;
Canvas.Draw(, , Buffer);
if Assigned(FOnPaint) then FOnPaint(Self);
end;  procedure TGlass.SetColor(Value: TColor);
begin
if Value <> FColor then
begin
FColor := Value;
RecreateWnd;
end;
end; procedure TGlass.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
end; procedure TGlass.WMWindowPosChanging(var Message: TWMWindowPosChanging);
begin
Invalidate;
inherited;
end; procedure TGlass.WMEraseBkgnd(var Message: TMessage);
begin
Message.Result := ;
end; procedure TGlass.Resize;
begin
Invalidate;
inherited;
end; procedure TGlass.CMCtl3DChanged(var Message: TMessage);
begin
inherited;
RecreateWnd;
end; procedure TGlass.SetStyle(Value: TGlassStyle);
begin
if Value <> FStyle then
begin
FStyle := Value;
RecreateWnd;
end;
end; end.
我也遇到同样的问题,能解决的话,另外我也开贴给分.
目前网上有不少代码.目前我使用的方法是
.重写TPanel的Create方法,增加
ControlStyle := ControlStyle - [csOpaque];
Brush.Style := bsClear;
.CreateParams方法,增加
with Params do
begin
ExStyle := ExStyle or WS_EX_TRANSPARENT;
end;
.重写Paint方法,直接将置空(我现在用的Panel只是做为一个容器用)
.获取WM_ERASEBKGND消息,Result为1 但是现在出现两个问题
.放置Panel的窗口发生变化时,Panel不显示
.Panel刷新后,背景没有刷新.(我在Panel上放了两个控件:控件1,控件2,这两个控件是交替显示的,发生交替的时候发现前面一个隐藏掉的控件还是画在了Panel上面,导致背景看起来很乱). 由于这个Panel是放在Form上使用的,我在Form上又放置了TImage控件,我希望Panel透明以后不要影响其他控件的显示效果,而现在网上的基本是靠获取Panel的父控件的背景来重画Panel背景实现,这种方式会影响其他控件的使用.
我结合网上搜到的资料,做了一个,基本能够达到我的应用了,但是还存在一个问题"放置Panel的窗口发生变化时,Panel不显示",
先把代码贴出来,大家帮忙看看哪边有问题.
//透明Panel
TTransparentPanel=class(TPanel)
protected
procedure Paint; override;
procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
procedure WMMove(var Message: TWMMove); Message WM_Move;
procedure AlignControls(AControl: TControl; var Rect: TRect); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure CreateParams(var Params: TCreateParams); override;
procedure Invalidate;override;
end; { TTransparentPanel } procedure TTransparentPanel.AlignControls(AControl: TControl; var Rect: TRect);
begin
inherited;
Invalidate;
end; constructor TTransparentPanel.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := ControlStyle - [csSetCaption];
ControlStyle := ControlStyle - [csOpaque];
end; procedure TTransparentPanel.CreateParams(var Params: TCreateParams);
begin
inherited;
with Params do
begin
ExStyle := ExStyle or WS_EX_TRANSPARENT;
end;
end; destructor TTransparentPanel.Destroy;
begin inherited Destroy;
end; procedure TTransparentPanel.Invalidate;
var
Rect: TRect;
iLoop: Integer;
begin
if (Parent<>nil) and(Parent.HandleAllocated) then
begin
Rect := BoundsRect;
InvalidateRect(Parent.Handle,@Rect,False);
for iLoop := to ControlCount- do
Controls[iLoop].Invalidate;
end;
end; procedure TTransparentPanel.Paint;
var
ARect: TRect;
TopColor, BottomColor: TColor; procedure AdjustColors(Bevel: TPanelBevel);
begin
TopColor := clBtnHighlight;
if Bevel = bvLowered then TopColor := clBtnShadow;
BottomColor := clBtnShadow;
if Bevel = bvLowered then BottomColor := clBtnHighlight;
end;
begin
ARect := GetClientRect;
if BevelOuter <> bvNone then
begin
AdjustColors(BevelOuter);
Frame3D(Canvas, ARect, TopColor, BottomColor, BevelWidth);
end;
Frame3D(Canvas, ARect, Color, Color, BorderWidth);
if BevelInner <> bvNone then
begin
AdjustColors(BevelInner);
Frame3D(Canvas, ARect, TopColor, BottomColor, BevelWidth);
end;
Update;
end; procedure TTransparentPanel.WMEraseBkgnd(var Message: TMessage);
begin
Message.Result := ;
end; procedure TTransparentPanel.WMMove(var Message: TWMMove);
begin
inherited;
Invalidate;
end;

delphi透明panel组件或者制作方法的更多相关文章

  1. delphi列表视图组件(TListView)使用方法|实例

    TListView 组件以多种形式显示列表的项目,如详细资料.小图标.大图标等形式表示列表中的项目.    列表视图与用TListBox 组件实现的列表框非常相似.不同的是,列表视图可以让用户选择不同 ...

  2. delphi中panel控件应用

    delphi中的panel控件是怎么使用的?研究了很久了,还是搞不懂,只知道把它放到form上面,其他操作一律不懂了,有谁可以请教一下,如何把其他控件放到里面去呢?谢谢 提问者采纳   直接把控件放到 ...

  3. 浅谈控件(组件)制作方法一(附带一delphi导出数据到Excel的组件实例)(原创)

    来自:http://blog.csdn.net/zhdwjie/article/details/1490741 -------------------------------------------- ...

  4. (转载)c++builder/delphi中透明panel及透明窗口的实现方法_delphi教程

    c++builder/delphi中透明panel及透明窗口的实现方法_delphi教程 可能大多数程序员会问:透明窗口,特别是透明Panel有什么应用价值呢?可别小看它们哦,下面我就来讲讲他们的巨大 ...

  5. 2016.5.30实现透明Panel及控件置顶的方法

    想放置一个透明Panel在某控件上端,实现效果是可透过此Panel看见下面控件,但鼠标点击却无任何反应. 1.新建置自定义Panel类 using System; using System.Colle ...

  6. delphi TAdoQuery组件的close方法可能导致”列名无效“错误

    1,故障现象 一次程序运行,出现如下错误: 对应代码如下: 2,故障分析 Query_alert_2的语句在查询分析器中单独执行是正常的.排除语句出错. 如果注解掉Query_alert_1,则错误变 ...

  7. 基于Delphi的三层数据库系统的实现方法

    基于Delphi的三层数据库系统的实现方法   1  引言 当前的数据库应用系统中,按其结构划分为两类,一类是两层结构的数据库应系统,另一类是多层结构的数据库应用系统. 两层结构的数据库应用系统包括客 ...

  8. Delphi 利用TComm组件 Spcomm 实现串行通信

    Delphi 利用TComm组件 Spcomm 实现串行通信 摘要:利用Delphi开发工业控制系统软件成为越来越多的开发人员的选择,而串口通信是这个过程中必须解决的问题之一.本文在对几种常用串口通信 ...

  9. Delphi 动态创建组件,单个创建、单个销毁

    效果图如下: 实现部分代码如下: var rec: Integer = 0; //记录增行按钮点击次数 implementation {$R *.dfm} //动态释放单个组件内存,即销毁组件 pro ...

随机推荐

  1. spring 新建mybatis ...

    一. 创建bean类 package com.feilong.blog.dao; public class Message { private int id; private String autho ...

  2. 新建门脸Facade类

    1.App\Contract目录下新建 CommonContract 类 <?php namespace App\Contract; use Carbon\Carbon; use \Dimsav ...

  3. LInux文件基础知识和文件目录操作(系统调用函数方式)

    1.进程是处于活动状态的程序,某个用户通过操作系统运行程序所产生的进程代表着该用户的行为.如果用户不具备访问某个目录和文件的权限,那么该用户的进程也不能访问. 2.Linux系统中文件安全机制是通过给 ...

  4. RF中alert的处理

    那么在robotframework中如何处理呢? 我在测试过程中遇到了这么一个窗口: 这种应该是属于Confirm 类型,是无法定位到的,在robotframework中需要这样处理: 1.虽然无法定 ...

  5. Spellchecker inspection helps locate typos and misspelling in your code, comments and literals, and fix them in one click

    Pycharm设置 Pycharm总是很多的拼写检查波拉线 Spellchecker inspection helps locate typos and misspelling in your cod ...

  6. Tomcat运行错误示例

    tomcat运行错误示例 当出现这种错误时,如果是自己配置的tomcat,需要找/conf/server.xml文件. 如果是使用的eclipse tomcat 插件,需要在你的工作空间 找到 如下文 ...

  7. 1.2 JSX 语法

    官方文档 https://facebook.github.io/react/docs/jsx-in-depth.html JSX 语法听上去很讨厌,但当真正使用的时候会发现,JSX 的写法在组件的组合 ...

  8. Linux两台机器简历信任

    cd ~/.ssh ssh-keygen  -t  rsa scp ./id_rsa.pub root@192.168.1.1:/root/.ssh/authorized_keys

  9. hbase之setCaching 和 setBatch 和setMaxResultSize

    scan的setBatch()用法 val conf = HBaseConfiguration.create() val table: Table = ConnectionFactory.create ...

  10. 拾遗:Go 单元测试

    概念 回归测试:是指修改了旧代码之后,重新进行测试,以确保修改没有引入新的错误或导致其它代码产生错误: 单元测试:是指对软件中的最小可测试单元(单个函数或类)进行检查和验证 Test-Driven D ...