当前页面位置: » 丰搜网 » 文档中心 » 详细内容
delphi控件，我们也可以(4)
下面是我的代码：
unit lxtouchlabel;
interface
uses
windows, messages, sysutils, classes, controls, stdctrls, graphics;
type
ttouchlabel = class(tlabel)
private
{ private declarations }
fcolor : tcolor;
ftouchcolor : tcolor;
ftempcolor : tcolor;
ftouchfont : tfont;
ftempfont : tfont;
isstoretouchfont : boolean;
function gettouchbkcolor : tcolor;
function isstoretouchbkcolor : boolean;
procedure settouchbkcolor(acolor : tcolor);
procedure settouchfont(afont : tfont);
procedure cmmouseenter(var message : tmessage); message cm_mouseenter;
procedure cmmouseleave(var message : tmessage); message cm_mouseleave;
protected
{ protected declarations }
public
{ public declarations }
constructor create(aowner: tcomponent); override;
destructor destroy; override;
published
{ published declarations }
property color;
property parentcolor;
property parentfont;
property touchbkcolor : tcolor read gettouchbkcolor write settouchbkcolor
stored isstoretouchbkcolor default clwindow;
property touchfont : tfont read ftouchfont write settouchfont
stored isstoretouchfont;
property changewhiletouch : boolean read isstoretouchfont
write isstoretouchfont default true;
end;
procedure register;
implementation
procedure register;
begin
registercomponents('lx', [ttouchlabel]);
end;
{ ttouchlabel }
constructor ttouchlabel.create(aowner: tcomponent);
begin
inherited;
ftempcolor := clwindow;
ftempfont := tfont.create;
ftouchfont := tfont.create;
isstoretouchfont := true;
end;
destructor ttouchlabel.destroy;
begin
ftempfont.free;
ftouchfont.free;
inherited;
end;
function ttouchlabel.gettouchbkcolor: tcolor;
begin
result := ftouchcolor;
end;
procedure ttouchlabel.settouchfont(afont: tfont);
begin
ftouchfont.assign(afont);
isstoretouchfont := true;
end;
procedure ttouchlabel.cmmouseenter(var message: tmessage);
begin
inherited;
if not changewhiletouch then exit;
if fcolor <> ftouchcolor then
begin
ftempcolor := color;
color := touchbkcolor;
end;
ftempfont.assign(font);
font.assign(touchfont);
end;
procedure ttouchlabel.cmmouseleave(var message: tmessage);
begin
inherited;
if not changewhiletouch then exit;
if fcolor <> ftouchcolor then
color := ftempcolor;
font.assign(ftempfont);
end;
procedure ttouchlabel.settouchbkcolor(acolor: tcolor);
begin
ftouchcolor := acolor;
end;
function ttouchlabel.isstoretouchbkcolor: boolean;
begin
result := (fcolor <> ftouchcolor);
end;
end.
///////////////////////////////////////////////////////////////////////
unit qlxtouchlable;
interface
uses
windows, messages, sysutils, classes, qcontrols, qstdctrls, qgraphics;
type
ttouchlable = class(tlabel)
private
{ private declarations }
fcolor : tcolor;
ftouchcolor : tcolor;
ftempcolor : tcolor;
ftouchfont : tfont;
ftempfont : tfont;
isstoretouchfont : boolean;
function gettouchcolor : tcolor;
function isstoretouchcolor : boolean;
procedure settouchcolor(acolor : tcolor);
procedure settouchfont(afont : tfont);
procedure mouseenter(acontrol: tcontrol); override;
procedure mouseleave(acontrol: tcontrol); override;
protected
{ protected declarations }
public
{ public declarations }
constructor create(aowner: tcomponent); override;
destructor destroy; override;
published
{ published declarations }
property color;
property parentcolor;
property parentfont;
property touchcolor : tcolor read gettouchcolor write settouchcolor
stored isstoretouchcolor default clwindow;
property touchfont : tfont read ftouchfont write settouchfont
stored isstoretouchfont;
property changewhiletouch : boolean read isstoretouchfont
write isstoretouchfont default true;
end;
procedure register;
implementation
procedure register;
begin
registercomponents('lx', [ttouchlable]);
end;
{ ttouchlable }
constructor ttouchlable.create(aowner: tcomponent);
begin
inherited;
ftempcolor := clwindow;
ftempfont := tfont.create;
ftouchfont := tfont.create;
isstoretouchfont := true;
end;
destructor ttouchlable.destroy;
begin
ftempfont.free;
ftouchfont.free;
inherited;
end;
function ttouchlable.gettouchcolor: tcolor;
begin
result := ftouchcolor;
end;
function ttouchlable.isstoretouchcolor: boolean;
begin
result := (fcolor <> ftouchcolor);
end;
procedure ttouchlable.mouseenter(acontrol: tcontrol);
begin
inherited;
if not changewhiletouch then exit;
if fcolor <> ftouchcolor then
begin
ftempcolor := color;
color := touchcolor;
end;
ftempfont.assign(font);
font.assign(touchfont);
end;
procedure ttouchlable.mouseleave(acontrol: tcontrol);
begin
inherited;
if not changewhiletouch then exit;
if fcolor <> ftouchcolor then
color := ftempcolor;
font.assign(ftempfont);
end;
procedure ttouchlable.settouchcolor(acolor: tcolor);
begin
ftouchcolor := acolor;
end;
procedure ttouchlable.settouchfont(afont: tfont);
begin
ftouchfont.assign(afont);
isstoretouchfont := true;
end;
end.
