给你一个单元,
支持 透明,背景图片,自动改变其上控件大小(有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
IntArray;
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.