各位高手:我的组件终于初步成功。但还没有最终实现我的目标,请帮一把(100分)

R

redted

Unregistered / Unconfirmed
GUEST, unregistred user!
各位高手:我的组件终于初步成功。但还没有最终实现我的目标,请帮一把
原意是两个shape稍错一点,下而的黑色,上面的彩色,再加一个透明的Label,当MOuse滑过上面的Shape时变色,离开时又恢复原色。代码如下
procedure TForm1.Shape1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
shape2.Brush.Color:=clLime;
end;

procedure TForm1.Label1Click(Sender: TObject);
begin
ShowMessage('ok');
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
shape2.Brush.color:=clGreen;
end;
--------------------------------------------------------------
现在成形控件的代码如下
uses
Windows, Messages, SysUtils, Classes, Controls, StdCtrls, Graphics, Forms,
Dialogs, Buttons, ExtCtrls;

type
TddgButtonEdit = class(TWinControl)
private
{ Private declarations }
FShape1:TShape;
FShape2:TShape;
FLabel:TLabel;
protected
{ Protected declarations }
procedure WMSize(var Message:TWMSize);message WM_SIZE;
procedure SetCaption(Value:String);
function GetCaption:String;
function GetFont:TFont;
procedure SetFont(Value:TFont);
function GetOnLabelClick:TNotifyEvent;
procedure SetOnLabelClick(Value:TNotifyEvent);
public
{ Public declarations }
Constructor Create(AOWner:TComponent);override;
destructor Destroy;override;
published
{ Published declarations }
Property Caption:String read GetCaption Write SetCaption;
property Font:TFont read GetFont Write SetFont;
Property OnClick:TNotifyEvent read GetOnLabelClick Write SetOnLabelClick;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Samples', [TddgButtonEdit]);
end;

procedure TddgButtonEdit.WMSize(var Message:TWMSize);
begin
inherited;
FShape2.Width:=Message.Width-2;
FShape2.Height:=Message.Height-4;
FShape2.left:=Message.Width-FShape2.Width;
FShape2.Top:=Message.Height-FShape2.Height;
FShape1.Left:=FShape2.Left-2;
FShape1.top:=FShape2.top-4;
end;

Constructor TddgButtonEdit.Create(AOWner:TComponent);
begin
inherited Create(AOWner);

FShape2:=TShape.create(self);
FShape2.Height:=42;
FShape2.Width:=77;
FShape2.Parent:=self;
FShape2.shape:=stEllipse;
FShape2.brush.Color:=clBlack;

FShape1:=TShape.create(self);
FShape1.Height:= FShape2.Height;
FShape1.Width:= FShape2.Width;
FShape1.Parent:=self;
FShape1.shape:=stEllipse;
FShape1.brush.Color:=clRed;

FLabel:=TLabel.Create(self);
FLabel.Left:=FShape1.Left+3;
FLabel.top:=FShape1.top+7;
FLabel.Height:=29;
FLabel.Width:=72;
FLabel.Height:=29;
FLabel.Width:=57;
FLabel.Alignment:=taCenter;
FLabel.AutoSize:=False;
FLabel.Parent:=self;
FLabel.Transparent:=true;
FLabel.Caption:='ColorButton';
FLabel.Font.Charset:=GB2312_CHARSET;
FLabel.Font.Size:=10;

Width:=FShape2.Width+2;
Height:=FShape2.height+4;

end;

destructor TddgButtonEdit.destroy;
begin
FShape1.free;
FShape2.free;
FLabel.Free;
inherited destroy;
end;

function TddgButtonEdit.GetCaption:String;
begin
Result:=FLabel.Caption;
end;

procedure TddgButtonEdit.SetCaption(Value:String);
begin
FLabel.Caption:=Value;
end;

function TddgButtonEdit.GetFont:TFont;
begin
Result:=FLabel.Font;
end;

procedure TddgButtonEdit.SetFont(Value:TFont);
begin
if Assigned(FLabel.Font) then
FLabel.Font.Assign(Value);
end;

function TddgButtonEdit.GetOnLabelClick:TNotifyEvent;
begin
Result:=FLabel.OnClick;
end;

procedure TddgButtonEdit.SetOnLabelClick(Value:TNotifyEvent);
begin
FLabel.OnClick:=Value;
end;

end.
我现在变色这一步实现不了,请帮一把,先谢

 
在定义里添加
procedure MouseOver(var Message:TWMMouse);message CM_MOUSEENTER;
procedure MouseLeave(var Message:TWMMouse);message CM_MOUSELEAVE;

实现
procedure TddgButtonEdit.MouseOver(var Message: TWMMouse);
begin
inherited;
FShape1.Brush.Color:=clBlue;
end;

procedure TddgButtonEdit.MouseLeave(var Message: TWMMouse);
begin
inherited;
FShape1.Brush.Color:=clRed;
end;
 
类似的代码:
procedure TADLabel.CMMouseEnter;
begin
FNormalColor:=Font.Color;

Font.Color:=FHoverColor; //改成链接颜色
Font.Style:=Font.Style+[fsUnderLine]; //加下划线
//if FWavResName<>'' then
// PlaySound(Pchar(FWavResName),HInstance,SND_ASYNC or SND_RESOURCE)
//else if (FWavFileName<>'') and FileExists(FWavFileName) then
// PlaySound(Pchar(FWavFileName),0,SND_ASYNC);
end;

procedure TADLabel.CMMouseLeave;
begin
Font.Color:=FNormalColor; //改变颜色
Font.Style:=Font.Style-[fsUnderLine]; //去除下划线
end;
 
哈哈,多谢两位,非常感谢!
 
顶部