关于从TCustomControl继承下来的自定义控件透明的问题，熟悉控件开发的朋友请进。 ( 积分: 200 )

  • 主题发起人 人生如路
  • 开始时间
人

人生如路

Unregistered / Unconfirmed
GUEST, unregistred user!
控件要实现的功能：
。在运行时有设计时效果，即是可以拖动，可以改变大小；
。控件的外表，主要要求两个形状，一是圆，一是矩形；
。控件要求透明；

源代码如下：===========================================
unit DesignbleShape;

interface

uses
Classes, Windows, Messages, Controls, StdCtrls, Graphics, ExtCtrls, Dialogs,
Themes;

const
sc_DragMove: Longint = $F012;
WM_RbsInvalidate=WM_USER+1;

type
TDesignbleShape = class (TCustomControl)
private
FRectList: array [1..8] of TRect;
FPosList: array [1..8] of Integer;
FShape: TShapeType;
FBrush: TBrush;
FPen: TPen;
FPointColor: TColor;
procedure SetShape(const Value: TShapeType);
procedure SetBrush(const Value: TBrush);
procedure SetPen(const Value: TPen);
procedure SetPointColor(const Value: TColor);

procedure WmNcHitTest(var Msg: TWMNCHitTest); message wm_NcHitTest;
procedure WmSize(var Msg: TWMSize); message wm_Size;
procedure WmLButtonDown(var Msg: TWMLButtonDown); message wm_LButtonDown;
procedure WmMove(var Msg: TWMMove); message wm_Move;
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;

procedure RbsInvalidate(var Message:TMessage); message WM_RbsInvalidate;
procedure CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT); message CN_CTLCOLOREDIT;

procedure DoDrawBakground;
protected
procedure StyleChanged(Sender: TObject);
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateHandle; override;
procedure CreateWnd; override;

procedure Do_Size;
procedure Paint; override;
public
constructor Create(AOwner: TComponent);override;
destructor Destroy;override;

property Shape: TShapeType read FShape write SetShape;
property Pen: TPen read FPen write SetPen;
property Brush: TBrush read FBrush write SetBrush;
property PointColor: TColor read FPointColor write SetPointColor;

property OnClick;
end;

implementation

// TDdhSizerControl methods
constructor TDesignbleShape.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle - [csOpaque];
Height := 100;
Width := 100;

FShape := stRectangle;
//create the list of positions
FPosList [1] := htTopLeft;
FPosList [2] := htTop;
FPosList [3] := htTopRight;
FPosList [4] := htRight;
FPosList [5] := htBottomRight;
FPosList [6] := htBottom;
FPosList [7] := htBottomLeft;
FPosList [8] := htLeft;
//
FPen := TPen.Create;
FPen.OnChange := StyleChanged;
FBrush := TBrush.Create;
FBrush.OnChange := StyleChanged;

FPointColor := clBlack;
//ParentBackground := False;
end;


procedure TDesignbleShape.CreateHandle;
begin
inherited CreateHandle;
SetFocus;
end;

procedure TDesignbleShape.CreateParams (var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle + ws_ex_Transparent;
end;

procedure TDesignbleShape.Paint;
var
I: Integer;
X, Y, W, H, S: Integer;
begin
DoDrawBakground;
with Canvas do
begin
Canvas.Brush.Color := clNone;
Canvas.Brush.Style := bsClear;
FillRect(ClientRect);

Pen.Assign(FPen);
Brush.Assign(FBrush);
X := Pen.Width div 2;
Y := X;
W := Width - Pen.Width + 1;
H := Height - Pen.Width + 1;
if Pen.Width = 0 then
begin
Dec(W);
Dec(H);
end;
if W < H then S := W else S := H;
if FShape in [stSquare, stRoundSquare, stCircle] then
begin
Inc(X, (W - S) div 2);
Inc(Y, (H - S) div 2);
W := S;
H := S;
end;
case FShape of
stRectangle, stSquare:
Rectangle(X, Y, X + W, Y + H);
stRoundRect, stRoundSquare:
RoundRect(X, Y, X + W, Y + H, S div 4, S div 4);
stCircle, stEllipse:
Ellipse(X, Y, X + W, Y + H);
end;
end;

Canvas.Brush.Color := PointColor;
Canvas.Brush.Style := bsSolid;
Canvas.Pen.Color := PointColor;
for I := 1 to 8 do
Canvas.Rectangle (FRectList .Left, FRectList .Top,
FRectList .Right, FRectList .Bottom);

end;

procedure TDesignbleShape.WmNcHitTest(var Msg: TWMNCHitTest);
var
Pt: TPoint;
I: Integer;
begin
inherited;
Pt := Point (Msg.XPos, Msg.YPos);
Pt := ScreenToClient (Pt);
Msg.Result := 0;
for I := 1 to 8 do
if PtInRect(FRectList, Pt) then
Msg.Result := FPosList ;
// if the return value was not set
if Msg.Result = 0 then
inherited;
end;

procedure TDesignbleShape.WmSize (var Msg: TWMSize);
begin
//inherited;
Do_Size;
end;


procedure TDesignbleShape.WmLButtonDown (var Msg: TWMLButtonDown);
begin
Perform(WM_SYSCOMMAND, sc_DragMove, 0);
end;


procedure TDesignbleShape.WmMove (var Msg: TWMMove);
begin
PostMessage(Handle, WM_RbsInvalidate,0,0)
//Paint;
end;


procedure TDesignbleShape.SetShape(const Value: TShapeType);
begin
if FShape <> Value then
begin
FShape := Value;
Invalidate;
end;
end;

procedure TDesignbleShape.SetBrush(const Value: TBrush);
begin
FBrush.Assign(Value);
end;

procedure TDesignbleShape.SetPen(const Value: TPen);
begin
FPen.Assign(Value);
end;

destructor TDesignbleShape.Destroy;
begin
FPen.Free;
FBrush.Free;
inherited;
end;

procedure TDesignbleShape.StyleChanged(Sender: TObject);
begin
Invalidate;
end;

procedure TDesignbleShape.SetPointColor(const Value: TColor);
begin
FPointColor := Value;
end;

procedure TDesignbleShape.Do_Size;
begin
//setup data structures
FRectList [1] := Rect(0, 0, 8, 8);
FRectList [2] := Rect(Width div 2 - 4, 0, Width div 2 + 4, 8);
FRectList [3] := Rect(Width - 8, 0, Width, 8);
FRectList [4] := Rect(Width - 8, Height div 2 - 4, Width, Height div 2 + 4);
FRectList [5] := Rect(Width - 8, Height - 8, Width, Height);
FRectList [6] := Rect(Width div 2 - 4, Height - 8, Width div 2 + 4, Height);
FRectList [7] := Rect(0, Height - 8, 8, Height);
FRectList [8] := Rect(0, Height div 2 - 4, 8, Height div 2 + 4);
end;

procedure TDesignbleShape.DoDrawBakground;
var
DesktopDC : HDC;
SelfDC : HDC;
ARect: TRect;
begin
DesktopDC := GetDC(0);
try
SelfDC := GetDC(Self.Handle);
try
ARect := GetClientRect;
Windows.ClientToScreen(Self.Handle, ARect.TopLeft);
Windows.ClientToScreen(Self.Handle, ARect.BottomRight);
BitBlt(SelfDC, 0, 0, Width, Height, DesktopDC, ARect.Left, ARect.Top, SRCCOPY);
finally
ReleaseDC(Self.Handle, SelfDC);
end;
finally
ReleaseDC(0, DesktopDC);
end;
end;

procedure TDesignbleShape.WMEraseBkgnd(var Message: TWmEraseBkgnd);
begin
//Message.Result := 1;
PostMessage(Handle, WM_RbsInvalidate,0,0)
end;

procedure TDesignbleShape.CNCTLCOLOREDIT(var Message: TWMCTLCOLOREDIT);
begin
// SetBkMode(ChildDC,Windows.TRANSPARENT);
// Result:=GetStockObject(HOLLOW_BRUSH)
end;

procedure TDesignbleShape.RbsInvalidate(var Message: TMessage);
var
R: TRect;
begin
if Parent <> nil 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 TDesignbleShape.CreateWnd;
begin
inherited;
SetWindowLong(Parent.Handle, GWL_STYLE, GetWindowLong(Parent.Handle, GWL_STYLE) and not WS_CLIPCHILDREN);
end;

end.
调用代码：========================================================

objDesignbleShape := TDesignbleShape.Create(Self);
objDesignbleShape.Parent := ScrollBox1;

objDesignbleShape.Top := 50;
objDesignbleShape.Left := 50;
objDesignbleShape.Height := 250;
objDesignbleShape.Width := 250;

objDesignbleShape.Pen.Width := 2;
objDesignbleShape.Pen.Color := clRed;
objDesignbleShape.Brush.Color := clWhite;
objDesignbleShape.Brush.Style := bsClear;

objDesignbleShape.PointColor := clYellow;
objDesignbleShape.Cursor := crSizeAll;
========================================================
现在的问题：
。要求一已实现，运行时有设计时效果；
。要求二也实现，为了简单，我只是简单的用了TShape的源码；
。要求三，在用鼠标点在八个点上面，可以改变大不，控件也是透明的；但是，在移动的时候，却不能做到透明；

其它现象：
。更改Shape值的时候，也不能透明；移动控件的时候，也不能透明；不透明的时候，用另外的Form挡它一下，再移开，它就透明了；



小弟想了很多办法了，实在是水平有限，怎么也试不出来。希望熟悉的朋友不吝赐教，先谢谢了。。。
 
控件要实现的功能：
。在运行时有设计时效果，即是可以拖动，可以改变大小；
。控件的外表，主要要求两个形状，一是圆，一是矩形；
。控件要求透明；

源代码如下：===========================================
unit DesignbleShape;

interface

uses
Classes, Windows, Messages, Controls, StdCtrls, Graphics, ExtCtrls, Dialogs,
Themes;

const
sc_DragMove: Longint = $F012;
WM_RbsInvalidate=WM_USER+1;

type
TDesignbleShape = class (TCustomControl)
private
FRectList: array [1..8] of TRect;
FPosList: array [1..8] of Integer;
FShape: TShapeType;
FBrush: TBrush;
FPen: TPen;
FPointColor: TColor;
procedure SetShape(const Value: TShapeType);
procedure SetBrush(const Value: TBrush);
procedure SetPen(const Value: TPen);
procedure SetPointColor(const Value: TColor);

procedure WmNcHitTest(var Msg: TWMNCHitTest); message wm_NcHitTest;
procedure WmSize(var Msg: TWMSize); message wm_Size;
procedure WmLButtonDown(var Msg: TWMLButtonDown); message wm_LButtonDown;
procedure WmMove(var Msg: TWMMove); message wm_Move;
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;

procedure RbsInvalidate(var Message:TMessage); message WM_RbsInvalidate;
procedure CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT); message CN_CTLCOLOREDIT;

procedure DoDrawBakground;
protected
procedure StyleChanged(Sender: TObject);
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateHandle; override;
procedure CreateWnd; override;

procedure Do_Size;
procedure Paint; override;
public
constructor Create(AOwner: TComponent);override;
destructor Destroy;override;

property Shape: TShapeType read FShape write SetShape;
property Pen: TPen read FPen write SetPen;
property Brush: TBrush read FBrush write SetBrush;
property PointColor: TColor read FPointColor write SetPointColor;

property OnClick;
end;

implementation

// TDdhSizerControl methods
constructor TDesignbleShape.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle - [csOpaque];
Height := 100;
Width := 100;

FShape := stRectangle;
//create the list of positions
FPosList [1] := htTopLeft;
FPosList [2] := htTop;
FPosList [3] := htTopRight;
FPosList [4] := htRight;
FPosList [5] := htBottomRight;
FPosList [6] := htBottom;
FPosList [7] := htBottomLeft;
FPosList [8] := htLeft;
//
FPen := TPen.Create;
FPen.OnChange := StyleChanged;
FBrush := TBrush.Create;
FBrush.OnChange := StyleChanged;

FPointColor := clBlack;
//ParentBackground := False;
end;


procedure TDesignbleShape.CreateHandle;
begin
inherited CreateHandle;
SetFocus;
end;

procedure TDesignbleShape.CreateParams (var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle + ws_ex_Transparent;
end;

procedure TDesignbleShape.Paint;
var
I: Integer;
X, Y, W, H, S: Integer;
begin
DoDrawBakground;
with Canvas do
begin
Canvas.Brush.Color := clNone;
Canvas.Brush.Style := bsClear;
FillRect(ClientRect);

Pen.Assign(FPen);
Brush.Assign(FBrush);
X := Pen.Width div 2;
Y := X;
W := Width - Pen.Width + 1;
H := Height - Pen.Width + 1;
if Pen.Width = 0 then
begin
Dec(W);
Dec(H);
end;
if W < H then S := W else S := H;
if FShape in [stSquare, stRoundSquare, stCircle] then
begin
Inc(X, (W - S) div 2);
Inc(Y, (H - S) div 2);
W := S;
H := S;
end;
case FShape of
stRectangle, stSquare:
Rectangle(X, Y, X + W, Y + H);
stRoundRect, stRoundSquare:
RoundRect(X, Y, X + W, Y + H, S div 4, S div 4);
stCircle, stEllipse:
Ellipse(X, Y, X + W, Y + H);
end;
end;

Canvas.Brush.Color := PointColor;
Canvas.Brush.Style := bsSolid;
Canvas.Pen.Color := PointColor;
for I := 1 to 8 do
Canvas.Rectangle (FRectList .Left, FRectList .Top,
FRectList .Right, FRectList .Bottom);

end;

procedure TDesignbleShape.WmNcHitTest(var Msg: TWMNCHitTest);
var
Pt: TPoint;
I: Integer;
begin
inherited;
Pt := Point (Msg.XPos, Msg.YPos);
Pt := ScreenToClient (Pt);
Msg.Result := 0;
for I := 1 to 8 do
if PtInRect(FRectList, Pt) then
Msg.Result := FPosList ;
// if the return value was not set
if Msg.Result = 0 then
inherited;
end;

procedure TDesignbleShape.WmSize (var Msg: TWMSize);
begin
//inherited;
Do_Size;
end;


procedure TDesignbleShape.WmLButtonDown (var Msg: TWMLButtonDown);
begin
Perform(WM_SYSCOMMAND, sc_DragMove, 0);
end;


procedure TDesignbleShape.WmMove (var Msg: TWMMove);
begin
PostMessage(Handle, WM_RbsInvalidate,0,0)
//Paint;
end;


procedure TDesignbleShape.SetShape(const Value: TShapeType);
begin
if FShape <> Value then
begin
FShape := Value;
Invalidate;
end;
end;

procedure TDesignbleShape.SetBrush(const Value: TBrush);
begin
FBrush.Assign(Value);
end;

procedure TDesignbleShape.SetPen(const Value: TPen);
begin
FPen.Assign(Value);
end;

destructor TDesignbleShape.Destroy;
begin
FPen.Free;
FBrush.Free;
inherited;
end;

procedure TDesignbleShape.StyleChanged(Sender: TObject);
begin
Invalidate;
end;

procedure TDesignbleShape.SetPointColor(const Value: TColor);
begin
FPointColor := Value;
end;

procedure TDesignbleShape.Do_Size;
begin
//setup data structures
FRectList [1] := Rect(0, 0, 8, 8);
FRectList [2] := Rect(Width div 2 - 4, 0, Width div 2 + 4, 8);
FRectList [3] := Rect(Width - 8, 0, Width, 8);
FRectList [4] := Rect(Width - 8, Height div 2 - 4, Width, Height div 2 + 4);
FRectList [5] := Rect(Width - 8, Height - 8, Width, Height);
FRectList [6] := Rect(Width div 2 - 4, Height - 8, Width div 2 + 4, Height);
FRectList [7] := Rect(0, Height - 8, 8, Height);
FRectList [8] := Rect(0, Height div 2 - 4, 8, Height div 2 + 4);
end;

procedure TDesignbleShape.DoDrawBakground;
var
DesktopDC : HDC;
SelfDC : HDC;
ARect: TRect;
begin
DesktopDC := GetDC(0);
try
SelfDC := GetDC(Self.Handle);
try
ARect := GetClientRect;
Windows.ClientToScreen(Self.Handle, ARect.TopLeft);
Windows.ClientToScreen(Self.Handle, ARect.BottomRight);
BitBlt(SelfDC, 0, 0, Width, Height, DesktopDC, ARect.Left, ARect.Top, SRCCOPY);
finally
ReleaseDC(Self.Handle, SelfDC);
end;
finally
ReleaseDC(0, DesktopDC);
end;
end;

procedure TDesignbleShape.WMEraseBkgnd(var Message: TWmEraseBkgnd);
begin
//Message.Result := 1;
PostMessage(Handle, WM_RbsInvalidate,0,0)
end;

procedure TDesignbleShape.CNCTLCOLOREDIT(var Message: TWMCTLCOLOREDIT);
begin
// SetBkMode(ChildDC,Windows.TRANSPARENT);
// Result:=GetStockObject(HOLLOW_BRUSH)
end;

procedure TDesignbleShape.RbsInvalidate(var Message: TMessage);
var
R: TRect;
begin
if Parent <> nil 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 TDesignbleShape.CreateWnd;
begin
inherited;
SetWindowLong(Parent.Handle, GWL_STYLE, GetWindowLong(Parent.Handle, GWL_STYLE) and not WS_CLIPCHILDREN);
end;

end.
调用代码：========================================================

objDesignbleShape := TDesignbleShape.Create(Self);
objDesignbleShape.Parent := ScrollBox1;

objDesignbleShape.Top := 50;
objDesignbleShape.Left := 50;
objDesignbleShape.Height := 250;
objDesignbleShape.Width := 250;

objDesignbleShape.Pen.Width := 2;
objDesignbleShape.Pen.Color := clRed;
objDesignbleShape.Brush.Color := clWhite;
objDesignbleShape.Brush.Style := bsClear;

objDesignbleShape.PointColor := clYellow;
objDesignbleShape.Cursor := crSizeAll;
========================================================
现在的问题：
。要求一已实现，运行时有设计时效果；
。要求二也实现，为了简单，我只是简单的用了TShape的源码；
。要求三，在用鼠标点在八个点上面，可以改变大不，控件也是透明的；但是，在移动的时候，却不能做到透明；

其它现象：
。更改Shape值的时候，也不能透明；移动控件的时候，也不能透明；不透明的时候，用另外的Form挡它一下，再移开，它就透明了；



小弟想了很多办法了，实在是水平有限，怎么也试不出来。希望熟悉的朋友不吝赐教，先谢谢了。。。
 
当你移动后 刷新...

肯定是重绘的问题.
 
呵。

哪位朋友有空，可以把我的代码COPY出去，运行试试。
 
TCustomControl是属于TWinControl继承下来的有句柄的,因此透明是比较麻烦的.对于这种要求透明得咚咚,其实还是TGraphicsControl比较合适。
在WinXP中GDI+支持某一个有句柄的窗体以他的父窗体为背景,也就是透明效果,但是如果两个子窗体重叠,那么这个重叠是现实不出来的.
 
我也试过从TGraphicsControl继承。不过，从TGraphicsControl继承的时候，我发现一个怪问题，我这个类中的WmNcHitTest这些消息，它收不到。

我在ControlStyle中，添加了Mouse事件的。

请指点。
 
TGraphicsControl已经没有句柄了,自然不会有什么Client区/NC的概念.这样的功能需要自己详细规划设计的,比如在你的响应鼠标的处理中,如果需要有NC的模拟,那么需要你自己去判断调用.
 
来自：zjan521, 时间：2005-9-8 23:59:11, ID：3197601
TGraphicsControl已经没有句柄了,自然不会有什么Client区/NC的概念.这样的功能需要自己详细规划设计的,比如在你的响应鼠标的处理中,如果需要有NC的模拟,那么需要你自己去判断调用.
====可否说详细一点？小弟愚笨，请指点。
 
其实，在坛子里面是有人从TCustomControl继承而解决了的。我在离线库中看到，发贴者说所用的代码也并不多。只不过那个贴子不全，而且，发贴者也并没有说出来。

所以，想请知道这个方法的朋友指点一下。呵。
 
TCustomControl也不是不可以.只需要把你的容器也重新绘制.
 
http://www.delphibbs.com/delphibbs/dispq.asp?LID=3197298
这里面是讨论透明PANEL的，你看看？？？
 
来自：zjan521, 时间：2005-9-9 19:56:43, ID：3199183
TCustomControl也不是不可以.只需要把你的容器也重新绘制.
=====我上面那个DoDrawBackground就是这样的想法，还是不行的。
 
app2001：谢谢了。我明天试试，我想，至少会给我很多启示。

其实，要做到透明很简单，我的这个类，在程序运行以后一显示出来的时候，就是透明的。

只不过，在Size的时候透明，在Move的时候却不透明。哎。
 
谢谢app2001给的url，小弟看了上面的代码受到启发，已经OK了。解决方法如下(离线资料库中那个王八不说解决方法，我来说)：
。如果你的控件在运行时要移动，就需要响应WM_WINDOWPOSCHANGING消息，重画表面；
。如果你的控件在改变风格、外观的时候，调用RecreateWnd方法；

也谢谢zjan521，分给你们两位了，小小意思，不成敬意。
 
您必须登录或注册才可回复。

Similar threads

I
一个Hint控件
回复
0
查看
429
import
I
I
一个模拟星空的控件
回复
0
查看
588
import
I
I
另外一个关于透明的贴子
回复
0
查看
400
import
I
I
图像旋转控件
回复
0
查看
583
import
I
I
用delphi编程实现XP界面效果
回复
0
查看
576
import
I
顶部