我写的一个构件,继承于tLabel,想实现在鼠标在文字上方时鼠标为crHandPoint,链接为红色.....(100分)

  • 主题发起人 主题发起人 ynfly
  • 开始时间 开始时间
Y

ynfly

Unregistered / Unconfirmed
GUEST, unregistred user!
我写的一个构件,继承于tLabel,想实现在鼠标在文字上方时鼠标为crHandPoint,
链接为红色,鼠标不在上方时,鼠标恢复正常,并且链接为蓝色,但是程序并没有按我的意图发展,
请各位兄弟姐妹帮忙看看,相信有构件编写的人来说是很容易的事,代码入下:

unit QNotesLink;

interface

uses
Windows,QDialogs, comobj,Messages, SysUtils, Classes, QControls, QGraphics,controls, StdCtrls;
type
tNotesLink = class(tlabel)
private
Ftempcursor:tcursor;
FmouseonCursor:tcursor; //鼠标在文字上方时的光标
Flinkcolor:tcolor; //链接显示的颜色
Fmouseonlinkcolor:tcolor;//鼠标在文字上方时的链接颜色
Fserver:string; //Notes链接的服务器
FdbName:string; //Notes链接的数据库
FdocUnid:string; //链接文档的UNID
procedure setLinkColor(value:tColor);
function getLinkColor:tColor;
procedure setMouseOnCursor(value:TcurSor);
function getMouseOnCursor:TCursor;
procedure setMouseOnLinkColor(value:tcolor);
function getMouseOnLinkColor:tColor;
procedure setServer(value:string);
function getServer:string;
procedure setDbName(value:string);
function getDbName:string;
procedure setDocUnid(value:string);
function getDocUnid:string;
{ Private declarations }
protected

{ Protected declarations }
public
procedure openLink(server:string;dbName:string;unid:string);
procedure onMouseMove(var msg:TMessage);message CM_MOUSEENTER;
procedure onMouseLeave(var msg:TMessage);message CM_MOUSELEAVE;
constructor create(Aowner:tcomponent);override;
destructor destroy;override;
{ Public declarations }
published
property linkColor:Tcolor read FLinkColor write setLinkcolor default clBlue;
property MouseOnCursor:TCursor read FMouseOnCursor write setMouseOnCursor default crHandPoint ;
property MouseOnLinkColor:Tcolor read FMouseOnLinkColor write setMouseOnLinkColor default clRed;
property server:string read Fserver write setserver;
property dbname:string read Fdbname write setdbname;
property docunid:string read Fdocunid write setdocunid;

{ Published declarations }
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('ActiveX', [tNotesLink]);
end;
function tNoteslink.getLinkColor:tcolor;
begin
result:=FlinkColor;
end;
procedure tNoteslink.setLinkColor(value:Tcolor);
begin
FlinkColor:=value;
invalidate;
end;
function tNoteslink.getMouseOnCursor:Tcursor;
begin
result:=FMouseOnCursor;
end;
procedure tNoteslink.setMouseOnCursor(value:Tcursor);
begin
FMouseOnCursor:=value;
invalidate;
end;
procedure tNoteslink.setMouseOnLinkColor(value:tcolor);
begin
FMouseOnLinkColor:=value;
invalidate;
end;
function tNoteslink.getMouseOnLinkColor :tcolor;
begin
result:=FMouseOnLinkColor;
end;
procedure tNoteslink.setServer(value:string);
begin
Fserver:=value;
end;
function tNoteslink.getServer :string;
begin
result:=Fserver;
end;
procedure tNoteslink.setDbName(value:string);
begin
FdbName:=value;
end;
procedure tNotesLink.setDocUnid(value:string);
begin
FDocUnid:=value;
end;
procedure tNotesLink.openLink(server:string;dbname:string;unid:string);
var ws:variant;
session:variant;
doc:variant;
db:variant;
begin
ws:=createoleobject('notes.notesuiworkspace');
session:=createoleobject('notes.notessession');
db:=session.getdatabase(fserver,fdbname);
doc:=db.getdocumentbyunid(fdocunid);
if not db.isopen then
begin
ws.opendatabase(fserver,fdbname);
end;
ws.editdocument(false,doc);
end;
function tNotesLink.getDbName:string;
begin
result:=FdbName;
end;
function tNotesLink.getDocUnid :string;
begin
result:=FdocUnid;
end;
procedure tNotesLink.onMouseMove(var msg:tmessage) ;
begin
//showmessage('mouseenter');
cursor:=FMouseOnCursor;
font.color:=FmouseonLinkColor;
invalidate;
end;
procedure tNotesLink.onMouseLeave (var msg:tmessage);
begin
//showmessage('mouseleave');
Cursor:=FtempCursor;
font.color:=Flinkcolor;
invalidate;
end;
constructor tNoteslink.create(Aowner:TComponent);
begin
inherited create(Aowner);
//FtempCursor:=crdefault;
//Flinkcolor:=clBlue;
//FMouseOnLinkColor:=clRed;
//FMouseOnCursor:=crHandPoint;
//font.color:=Flinkcolor;

end;
destructor tNoteslink.destroy ;
begin
inherited destroy;
end;
end.
 
???
我试了一切正常啊,你别注释掉那几行.
 
我是要求鼠标在文字上面时鼠标变成crHandPoint,且链接颜色为红色,
不在上方的时候鼠标为crDefault,链接颜色为蓝色,我试了很多次,都不行,
好像在为FMouseOnLinkColor、FMouseOnCursor、FLinkColor等属性时出了问题,
初始化值都为0.帮忙再看看。
 
38. 再谈Leave事件
在孜孜的文章《TButton增加MouseLeave事件》中,谈到了 CM_MOUSELEAVE,这是一个Inprise公司中未归档的消息,发生于离开控件的时候;同样还有一个CM_MOUSEENTER消息,发生于进入控件时,因此我在下面编写了一个关于超链接的Label类。
unit ZeroLinkLabelUnit;
//Zero Studio Delphi Link Label Component
//panying@sina.com
//Version 1.1
{
Unit ZeroLinkLabelUnit
A label when click will lead to an url CopyRight 2001, Zero Studio
Web Site:http://zeroworld.533.net
or http://zeroworld.yes8.com
Version 1.1
New Feature:
When mouse move on label,the label will add underline.
Version 1.0
Initial Version
Attention:
This software is provided 'as-is', without any express or implied warranty. In no event will the author be held liable for any damages arising from the use of this software.
This unit is free to use but the origin of this software must not be misrepresented, you must not claim that you wrote the original software.
Feel free to use this component in your product including commercial applications.
If You alert this component's code to make it better, please remember to tell me about it , let's to make it better together.
This attention may not be removed or altered from any source distribution.
}
interface
uses Stdctrls,Classes,Controls,Forms,Windows,Graphics,ShellAPI,Messages;
type
TZeroLinkLabel=class(TLabel)
private
fUrl: string;
procedure LinkTo;
procedure ZeroMouseLeave(var Msg:TMessage);message CM_MOUSELEAVE;
procedure ZeroMouseEnter(var Msg:TMessage);message CM_MOUSEENTER;
procedure SetUrl(const Value: string);
protected
procedure Click;override;
published
property Url:string read fUrl write SetUrl;
public
constructor Create(AOwner: TComponent);override;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TZeroLinkLabel]);
end;

{ TZeroLinkLabel }
procedure TZeroLinkLabel.Click;
begin
if not (csDesigning in ComponentState)and (fUrl <>'') then LinkTo;
inherited Click;
end;

constructor TZeroLinkLabel.Create(AOwner: TComponent);
begin
inherited;
//set default font
Font.Color:=clBlue;
//set default cursor
Cursor:=crHandPoint;
end;
procedure TZeroLinkLabel.LinkTo;
begin
ShellExecute(Application.handle,'open',pchar(fUrl),nil,nil,SW_SHOWNORMAL);
end;
procedure TZeroLinkLabel.SetUrl(const Value: string);
begin
fUrl:=Value;
end;
procedure TZeroLinkLabel.ZeroMouseEnter(var Msg: TMessage);
begin
Font.Style:=Font.Style+[fsUnderLine];
end;
procedure TZeroLinkLabel.ZeroMouseLeave(var Msg: TMessage);
begin
Font.Style:=Font.Style-[fsUnderLine];
end;
end.
 
是我的错,我原来作的测试用的project上开始放置了一个Tnoteslink控件,但是在Tnoteslink
控件更改后没有在project上更改此控件,不好意思,麻烦你了,
分就见者有份了
 
后退
顶部