开源控件大家做（2） URL标签

逍遥派掌门人 · 发表于 2012-3-6 15:35:27

功能：在标签上显示URL网址，点击标签，则跳转到相应的网址。

代码简单，直接贴上来：

unit URLlabel;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,Windows,ShellAPI;
type
TURLlabel = class(TCustomLabel)
private
{ Private declarations }
fURL : String;
procedure SetURL(value : string);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create (AOwner : TComponent); override;
procedure Click; override;
published
{ Published declarations }
Property URL : String Read fURL write setURL;
Property Align;
Property Alignment;
Property AutoSize;
Property caption;
Property Color;
Property Cursor;
Property Font;
Property ParentFont;
end;
procedure Register;
implementation
procedure TURLlabel.Click;
begin
ShellExecute(0, 'open', PChar(fURL), nil, nil, SW_SHOWNORMAL);
inherited;
end;
procedure TURLlabel.SetURL(value : string);
begin
if fURL <> Value then
begin
Caption := Value;
fURL := Value;
end;
end;
constructor TURLlabel.Create(AOwner: TComponent);
begin
inherited ;
Font.Color := clBlue;
Font.Style := [fsUnderline];
Cursor := crHandPoint;
URL :='http://www.fpccn.com';
end;
procedure Register;
begin
{$I urllabel_icon.lrs}
RegisterComponents('fpccn',[TURLlabel]);
end;
end.

复制代码

逍遥派掌门人 · 发表于 2012-3-6 15:35:57

等交作业的。。。。。。。

逍遥派掌门人 · 发表于 2012-3-12 13:43:47

是Windows的。
没有在linux下验证过。

逍遥派掌门人 · 发表于 2012-3-12 13:56:06

多谢 delphicn的提示。
================================================================
更新后的代码：

unit URLlabel;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,LCLIntf;
type
TURLlabel = class(TCustomLabel)
private
{ Private declarations }
fURL : String;
procedure SetURL(value : string);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create (AOwner : TComponent); override;
procedure Click; override;
published
{ Published declarations }
Property URL : String Read fURL write setURL;
Property Align;
Property Alignment;
Property AutoSize;
Property caption;
Property Color;
Property Cursor;
Property Font;
Property ParentFont;
end;
procedure Register;
implementation
procedure TURLlabel.Click;
begin
OpenURL(fURL);
inherited;
end;
procedure TURLlabel.SetURL(value : string);
begin
if fURL <> Value then
begin
Caption := Value;
fURL := Value;
end;
end;
constructor TURLlabel.Create(AOwner: TComponent);
begin
inherited ;
Font.Color := clBlue;
Font.Style := [fsUnderline];
Cursor := crHandPoint;
URL :='http://www.fpccn.com';
end;
procedure Register;
begin
{$I urllabel_icon.lrs}
RegisterComponents('fpccn',[TURLlabel]);
end;
end.

复制代码

================================================================
请使用linux系统的朋友测试，这个控件是否也可以在linux里使用。

pcplayer · 发表于 2012-3-8 18:40:48

ShellExecute 是 WIN32 的一个 API

如果是 LINUX 呢？

delphicn · 发表于 2012-3-8 19:34:26

uses LCLIntf;

procedure TURLlabel.Click;
begin
  //ShellExecute(0, 'open', PChar(fURL), nil, nil, SW_SHOWNORMAL);
  OpenURL(TURLlabel(Sender).Caption);
  inherited;
end;

1234567 · 发表于 2012-4-3 15:19:56

请教掌门人:如果用shellexecute打开路径带汉字的文件,该如何写?不知该如何转换
谢谢

逍遥派掌门人 · 发表于 2012-4-5 14:34:34

路径转换过来就可以了： UTF8TOSys(你的路径)

1234567 · 发表于 2012-4-7 14:45:24

逍遥派掌门人:路径转换过来就可以了： UTF8TOSys(你的路径)
 (2012-04-05 14:34) 

谢谢掌门人

piaoxueboy · 发表于 2012-4-25 17:54:51

其实这个控件在linux中能否运行关键是看OpenURL(fURL) 这句能否正确执行

很幸运的是 OpenURL(fURL) 这句在lazarus for linux下可以正确的执行

		自动登录	找回密码
密码			立即注册（注册审核可向QQ群索取）

[Lazarus实战宝典] 开源控件大家做（2） URL标签

回 7楼(逍遥派掌门人) 的帖子

浏览过的版块