谁能给出一个详细的透明控件例子(button,pelnel),经验证后,送300分(300分)

  • 主题发起人 主题发起人 我是一个贼
  • 开始时间 开始时间

我是一个贼

Unregistered / Unconfirmed
GUEST, unregistred user!
谁能给出一个详细的透明控件例子(button,pelnel),经验证后,送300分[red][/red]
 
一个透明edit控件,自己参考一下了。

unit RbsWiredEdit;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

const
TWM_RbsInvalidate=WM_USER+1;

type
TRbsWiredEdit = class(TEdit)
private
{ Private declarations }
procedure RbsInvalidate(var Message:TMessage); message
TWM_RbsInvalidate;
procedure CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT); message
CN_CTLCOLOREDIT;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMMove(var Message: TMessage); message WM_MOVE;

protected
{ Protected declarations }
FTransparent: boolean;
procedure CreateWnd; override;
procedure CreateParams(var Params: TCreateParams); override;
procedure DoExit; override;
procedure DoEnter; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
procedure Invalidate; override;

published
{ Published declarations }
end;

procedure Register;

implementation

constructor TRbsWiredEdit.Create(AOwner:TComponent);
begin
inherited create(AOwner);
ftransparent:=true;
end;

procedure TRbsWiredEdit.CreateWnd;
begin
inherited CreateWnd;
if fTransparent then
begin
SetWindowLong(Parent.Handle, GWL_STYLE,
GetWindowLong(Parent.Handle, GWL_STYLE) and not WS_CLIPCHILDREN);
end;
end;

procedure TRbsWiredEdit.RbsInvalidate(var Message:TMessage);
var r:TRect;
begin
if (Parent<>nil) and FTransparent then
begin
r:=ClientRect;
r.TopLeft:=Parent.ScreenToClient(ClientToScreen(r.TopLeft));
r.BottomRight:=Parent.ScreenToClient(ClientToScreen(r.BottomRight));
RedrawWindow(Handle,nil,0,RDW_FRAME+RDW_INVALIDATE);
end;
end;

procedure TRbsWiredEdit.CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT);
begin
if FTransparent then
with Message do
begin
SetBkMode(ChildDC,Windows.TRANSPARENT);
Result:=GetStockObject(HOLLOW_BRUSH)
end
else inherited;
end;



procedure TRbsWiredEdit.WMEraseBkgnd(var Message:TWMERASEBKGND);
begin
if FTransparent and not (csDesigning in ComponentState) then
PostMessage(Handle,TWM_RbsInvalidate,0,0)
else inherited;
end;

procedure TRbsWiredEdit.WMMove(var message:TMessage);
begin
inherited;
if FTransparent then SendMessage(Handle,TWM_RbsInvalidate,0,0)
else Invalidate;
end;

procedure TRbsWiredEdit.CreateParams(var Params:TCreateParams);
begin
inherited CreateParams(Params);
if (CsDesigning in ComponentState) then exit;
with Params do
begin
ExStyle:=ExStyle or WS_EX_TRANSPARENT;
end;
end;

procedure TRbsWiredEdit.DoExit;
begin
inherited;
FTransparent:=true;
SetCursor(0);
RecreateWnd;
end;

procedure TRbsWiredEdit.DoEnter;
var exstyle,stdstyle:longint;
begin
inherited;
Ftransparent:=false;
StdStyle:= Windows.GetWindowLong(handle, GWL_EXSTYLE);
exStyle:= StdStyle and not WS_EX_TRANSPARENT;
Windows.SetWindowLong(handle, GWL_EXSTYLE, exStyle);
invalidate;
end;

procedure TRbsWiredEdit.Invalidate;
begin
if FTransparent then SendMessage(Handle,TWM_RbsInvalidate,0,0)
else inherited;
end;

procedure Register;
begin
RegisterComponents('Rombest', [TRbsWiredEdit]);
end;

end.
 
unit RbsWiredEdit;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

const
TWM_RbsInvalidate=WM_USER+1;

type
TRbsWiredEdit = class(TEdit)
private
{ Private declarations }
procedure RbsInvalidate(var Message:TMessage); message
TWM_RbsInvalidate;
procedure CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT); message
CN_CTLCOLOREDIT;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMMove(var Message: TMessage); message WM_MOVE;

protected
{ Protected declarations }
FTransparent: boolean;
procedure CreateWnd; override;
procedure CreateParams(var Params: TCreateParams); override;
procedure DoExit; override;
procedure DoEnter; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
procedure Invalidate; override;

published
{ Published declarations }
end;

procedure Register;

implementation

constructor TRbsWiredEdit.Create(AOwner:TComponent);
begin
inherited create(AOwner);
ftransparent:=true;
end;

procedure TRbsWiredEdit.CreateWnd;
begin
inherited CreateWnd;
if fTransparent then
begin
SetWindowLong(Parent.Handle, GWL_STYLE,
GetWindowLong(Parent.Handle, GWL_STYLE) and not WS_CLIPCHILDREN);
end;
end;

procedure TRbsWiredEdit.RbsInvalidate(var Message:TMessage);
var r:TRect;
begin
if (Parent<>nil) and FTransparent then
begin
r:=ClientRect;
r.TopLeft:=Parent.ScreenToClient(ClientToScreen(r.TopLeft));
r.BottomRight:=Parent.ScreenToClient(ClientToScreen(r.BottomRight));
RedrawWindow(Handle,nil,0,RDW_FRAME+RDW_INVALIDATE);
end;
end;

procedure TRbsWiredEdit.CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT);
begin
if FTransparent then
with Message do
begin
SetBkMode(ChildDC,Windows.TRANSPARENT);
Result:=GetStockObject(HOLLOW_BRUSH)
end
else inherited;
end;



procedure TRbsWiredEdit.WMEraseBkgnd(var Message:TWMERASEBKGND);
begin
if FTransparent and not (csDesigning in ComponentState) then
PostMessage(Handle,TWM_RbsInvalidate,0,0)
else inherited;
end;

procedure TRbsWiredEdit.WMMove(var message:TMessage);
begin
inherited;
if FTransparent then SendMessage(Handle,TWM_RbsInvalidate,0,0)
else Invalidate;
end;

procedure TRbsWiredEdit.CreateParams(var Params:TCreateParams);
begin
inherited CreateParams(Params);
if (CsDesigning in ComponentState) then exit;
with Params do
begin
ExStyle:=ExStyle or WS_EX_TRANSPARENT;
end;
end;

procedure TRbsWiredEdit.DoExit;
begin
inherited;
FTransparent:=true;
SetCursor(0);
RecreateWnd;
end;

procedure TRbsWiredEdit.DoEnter;
var exstyle,stdstyle:longint;
begin
inherited;
Ftransparent:=false;
StdStyle:= Windows.GetWindowLong(handle, GWL_EXSTYLE);
exStyle:= StdStyle and not WS_EX_TRANSPARENT;
Windows.SetWindowLong(handle, GWL_EXSTYLE, exStyle);
invalidate;
end;

procedure TRbsWiredEdit.Invalidate;
begin
if FTransparent then SendMessage(Handle,TWM_RbsInvalidate,0,0)
else inherited;
end;

procedure Register;
begin
RegisterComponents('Rombest', [TRbsWiredEdit]);
end;

end.
 
给你一个单元,
支持 透明,背景图片,自动改变其上控件大小(有BUG)
透明和背景图片 (互相排斥)

=======================================================
unit AutoPnl;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;

type

TPlacement = record
Left, Top, Width, Height: Integer;
end;



PIntArray = ^TRectArray;
TRectArray = array[0..4096] of TPlacement;

TAutoPanel = class(TCustomPanel)
private
{ Private declarations }
FWallpaper: TPicture;
FTransparent: Boolean;
procedure SetTransparent(value: Boolean);
// procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;
procedure WallpaperChanged(Sender: TObject);
procedure SetWallpaper(Value: TPicture);

protected
{ Protected declarations }
pWidth :Integer;
pHeight:Integer;
FAutoChildPosLeft : Boolean;
FAutoChildPosTop : Boolean;
FAutoChildWidth : Boolean;
FAutoChildHeight : Boolean;
PCtrlsCoordArr:PIntArray;
procedure Resize; override;
procedure Paint; override;
// procedure CreateParams(var Params: TCreateParams); override;
// procedure SetParent(AParent: TWinControl); override;
procedure DrawParentImage(Control: TControl; Dest: TCanvas);
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Loaded; override;
// procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;

published
property AutoChildPosLeft : Boolean read FAutoChildPosLeft write FAutoChildPosLeft default False;
property AutoChildPosTop : Boolean read FAutoChildPosTop write FAutoChildPosTop default False;
property AutoChildWidth : Boolean read FAutoChildWidth write FAutoChildWidth default False;
property AutoChildHeight : Boolean read FAutoChildHeight write FAutoChildHeight default False;

property Align;
property Alignment;
property BevelInner;
property BevelOuter;
property BevelWidth;
property BorderWidth;
property BorderStyle;
property DragCursor;
property DragMode;
property Enabled;
property Caption;
property Color;
property Ctl3D;
property Font;
property Locked;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
// property ParentShowHint default False;
property ShowHint default true;
property TabOrder;
property TabStop;
property Wallpaper: TPicture read FWallpaper write SetWallpaper;
property Transparent: Boolean read FTransparent write SetTransparent default false;
property Visible;

property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDrag;

{$IFDEF VER120} {Borland Delphi 4.0 }
property Anchors;
property AutoSize;
property BiDiMode;
property Constraints;
property UseDockManager default True;
property DockSite;
property DragKind;
property FullRepaint;
property ParentBiDiMode;

property OnCanResize;
property OnConstrainedResize;
property OnDockDrop;
property OnDockOver;
property OnEndDock;
property OnGetSiteInfo;
property OnStartDock;
property OnUnDock;
{$ENDIF}

{ Published declarations }
end;

procedure Register;

implementation

procedure TAutoPanel.DrawParentImage(Control: TControl; Dest: TCanvas);
var
SaveIndex: Integer;
DC: HDC;
Position: TPoint;
begin
with Control do
begin
if Parent = nil then
Exit;
DC := Dest.Handle;
SaveIndex := SaveDC(DC);
{$IFDEF DFS_COMPILER_2}
GetViewportOrgEx(DC, @Position);
{$ELSE}
GetViewportOrgEx(DC, Position);
{$ENDIF}
SetViewportOrgEx(DC, Position.X - Left, Position.Y - Top, nil);
IntersectClipRect(DC, 0, 0, Parent.ClientWidth, Parent.ClientHeight);
Parent.Perform(WM_ERASEBKGND, DC, 0);
Parent.Perform(WM_PAINT, DC, 0);
RestoreDC(DC, SaveIndex);
end;
end;

constructor TAutoPanel.Create(AOwner: TComponent);
begin
inherited;
FAutoChildPosLeft := False;
FAutoChildPosTop := False;
FAutoChildWidth := False;
FAutoChildHeight := False;
pWidth := -1;
pHeight := -1;
PCtrlsCoordArr := nil;
FWallpaper := TPicture.Create;
FWallpaper.OnChange := WallpaperChanged;
ParentShowHint := False;
ShowHint := True;
// inherited Align := alTop;
end;


destructor TAutoPanel.Destroy;
begin
FreeMem(PCtrlsCoordArr);
FWallpaper.OnChange := nil;
FWallpaper.Free;
FWallpaper := nil;
inherited;
end;

procedure TAutoPanel.Loaded;
var i:Integer;
begin
inherited Loaded;
if (csDesigning in ComponentState) then Exit;

if (pWidth = -1) and (pHeight = -1) then begin
GetMem(PCtrlsCoordArr, ControlCount * sizeof(TRect));
for i := 0 to ControlCount - 1 do begin
PCtrlsCoordArr.Left := Controls.Left;
PCtrlsCoordArr.Top := Controls.Top;
PCtrlsCoordArr.Width := Controls.Width;
PCtrlsCoordArr.Height := Controls.Height;
end;
pWidth := Width;
pHeight := Height;
end;
end;

procedure TAutoPanel.Resize;
var
I:Integer;
// Ph:integer;
begin
inherited;
if (csDesigning in ComponentState) then Exit;
try

if (AutoChildPosLeft = false) and (AutoChildWidth = false) and
(AutoChildPosTop = false) and (AutoChildHeight = false) then Exit;

for i := 0 to ControlCount - 1 do begin
if(AutoChildPosLeft = true) then
if (AutoChildWidth = true) then begin
Controls.Left := MulDiv (PCtrlsCoordArr.Left,Width,pWidth);
Controls.Width := MulDiv (PCtrlsCoordArr.Width,Width,pWidth);
end
else
Controls.Left := Round(
PCtrlsCoordArr.Left * Width / pWidth +
((PCtrlsCoordArr.Width) * Width / pWidth -
(PCtrlsCoordArr.Width))/2
);

if(AutoChildPosTop = true) then
if (AutoChildHeight = true) then begin
Controls.Top := MulDiv (PCtrlsCoordArr.Top,Height,pHeight);
Controls.Height := MulDiv (PCtrlsCoordArr.Height,Height,pHeight);
end
else

Controls.Top := Round(
PCtrlsCoordArr.Top * Height / pHeight +
((PCtrlsCoordArr.Height) * Height / pHeight - (PCtrlsCoordArr.Height))/2 );
end;
finally
end;
end;

//=======
procedure TAutoPanel.WallpaperChanged(Sender: TObject);
begin
Invalidate;
end;

procedure TAutoPanel.SetWallpaper(Value: TPicture);
begin
FWallpaper.Assign(Value);
end;

procedure TAutoPanel.Paint;
var
XCnt, YCnt, X, Y: Integer;
BevelSize, SaveIndex: Integer;
Rect: TRect;
bitmap:tbitmap;
begin
inherited Paint;
if (FWallpaper.Graphic = nil) and FTransparent then
begin
// if not (csDesigning in ComponentState) then
// exit;
Bitmap := TBitmap.Create;
try
Bitmap.Height := ClientRect.Bottom;
Bitmap.Width := ClientRect.Right;
DrawParentImage(Self, Bitmap.Canvas);
canvas.CopyRect(ClientRect, Bitmap.canvas, ClientRect);
finally
Bitmap.free;
end;
end
else
begin
if (FWallpaper.Graphic <> nil) and (FWallpaper.Width > 0) and
(FWallpaper.Height > 0) then
begin
Rect := ClientRect;
BevelSize := BorderWidth;
if BevelOuter <> bvNone then Inc(BevelSize, BevelWidth);
if BevelInner <> bvNone then Inc(BevelSize, BevelWidth);
InflateRect(Rect, -BevelSize, -BevelSize);
SaveIndex := SaveDC(Canvas.Handle);
try
IntersectClipRect(Canvas.Handle, Rect.Left, Rect.Top,
Rect.Right -Rect.Left +1,
Rect.Bottom-Rect.Top +1 );
XCnt := (ClientWidth - 2 * BevelSize) div FWallpaper.Width;
YCnt := (ClientHeight - 2 * BevelSize) div FWallpaper.Height;
for X := 0 to XCnt do
for Y := 0 to YCnt do
Canvas.Draw(Rect.Left + X * FWallpaper.Width,
Rect.Top + Y * FWallpaper.Height, FWallpaper.Graphic);
finally
RestoreDC(Canvas.Handle, SaveIndex);
end;
end;
end;
end;

//=======

//透明
procedure TAutoPanel.SetTransparent(value: boolean);
begin
if ftransparent <> value then
begin
ftransparent := value;
invalidate;
end;
end;

{procedure TAutoPanel.WMEraseBkgnd(var Msg: TMessage);
begin
if ftransparent then msg.result := 1
else inherited;
end;

procedure TAutoPanel.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
params.exstyle := params.exstyle or WS_EX_TRANSPARENT;
end;

procedure TAutoPanel.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 TAutoPanel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
invalidate;
inherited setbounds(aleft, atop, awidth, aheight);
end;}

//

//

procedure Register;
begin
RegisterComponents('Xac', [TAutoPanel]);
end;

end.
 
很感谢这么多人的代码,一经验证后我立即给分。
 
多人接受答案了。
 
后退
顶部