请选择 进入手机版 | 继续访问电脑版

Lazarus中文社区

 找回密码
 立即注册

QQ登录

只需一步,快速开始

Lazarus IDE and 组件 下载地址版权申明
查看: 2057|回复: 9

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

[复制链接]

该用户从未签到

发表于 2012-3-6 15:35:27 | 显示全部楼层 |阅读模式
功能:在标签上显示URL网址,点击标签,则跳转到相应的网址。

代码简单,直接贴上来:
  1. unit URLlabel;
  2. {$mode objfpc}{$H+}
  3. interface
  4. uses
  5.   Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,Windows,ShellAPI;
  6. type
  7.   TURLlabel = class(TCustomLabel)
  8.   private
  9.     { Private declarations }
  10.     fURL : String;
  11.     procedure SetURL(value : string);
  12.   protected
  13.     { Protected declarations }
  14.   public
  15.     { Public declarations }
  16.     constructor Create (AOwner : TComponent); override;
  17.     procedure Click; override;
  18.   published
  19.     { Published declarations }
  20.     Property URL : String Read fURL write setURL;
  21.     Property Align;
  22.     Property Alignment;
  23.     Property AutoSize;
  24.     Property caption;
  25.     Property Color;
  26.     Property Cursor;
  27.     Property Font;
  28.     Property ParentFont;
  29.   end;
  30. procedure Register;
  31. implementation
  32. procedure TURLlabel.Click;
  33. begin
  34.   ShellExecute(0, 'open', PChar(fURL), nil, nil, SW_SHOWNORMAL);
  35.   inherited;
  36. end;
  37. procedure TURLlabel.SetURL(value : string);
  38. begin
  39.   if fURL <> Value then
  40.   begin
  41.     Caption := Value;
  42.     fURL := Value;
  43.   end;
  44. end;
  45. constructor TURLlabel.Create(AOwner: TComponent);
  46. begin
  47.   inherited ;
  48.   Font.Color := clBlue;
  49.   Font.Style := [fsUnderline];
  50.   Cursor     := crHandPoint;
  51.   URL :='http://www.fpccn.com';
  52. end;
  53. procedure Register;
  54. begin
  55.   {$I urllabel_icon.lrs}
  56.   RegisterComponents('fpccn',[TURLlabel]);
  57. end;
  58. end.                                 
复制代码
回复

使用道具 举报

该用户从未签到

 楼主 发表于 2012-3-6 15:35:57 | 显示全部楼层
等交作业的。。。。。。。
回复 支持 反对

使用道具 举报

该用户从未签到

 楼主 发表于 2012-3-12 13:43:47 | 显示全部楼层
是Windows的。
没有在linux下验证过。
回复 支持 反对

使用道具 举报

该用户从未签到

 楼主 发表于 2012-3-12 13:56:06 | 显示全部楼层
多谢 delphicn的提示。
================================================================
更新后的代码:
  1. unit URLlabel;
  2. {$mode objfpc}{$H+}
  3. interface
  4. uses
  5.   Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,LCLIntf;
  6. type
  7.   TURLlabel = class(TCustomLabel)
  8.   private
  9.     { Private declarations }
  10.     fURL : String;
  11.     procedure SetURL(value : string);
  12.   protected
  13.     { Protected declarations }
  14.   public
  15.     { Public declarations }
  16.     constructor Create (AOwner : TComponent); override;
  17.     procedure Click; override;
  18.   published
  19.     { Published declarations }
  20.     Property URL : String Read fURL write setURL;
  21.     Property Align;
  22.     Property Alignment;
  23.     Property AutoSize;
  24.     Property caption;
  25.     Property Color;
  26.     Property Cursor;
  27.     Property Font;
  28.     Property ParentFont;
  29.   end;
  30. procedure Register;
  31. implementation
  32. procedure TURLlabel.Click;
  33. begin
  34.   OpenURL(fURL);
  35.   inherited;
  36. end;
  37. procedure TURLlabel.SetURL(value : string);
  38. begin
  39.   if fURL <> Value then
  40.   begin
  41.     Caption := Value;
  42.     fURL := Value;
  43.   end;
  44. end;
  45. constructor TURLlabel.Create(AOwner: TComponent);
  46. begin
  47.   inherited ;
  48.   Font.Color := clBlue;
  49.   Font.Style := [fsUnderline];
  50.   Cursor     := crHandPoint;
  51.   URL :='http://www.fpccn.com';
  52. end;
  53. procedure Register;
  54. begin
  55.   {$I urllabel_icon.lrs}
  56.   RegisterComponents('fpccn',[TURLlabel]);
  57. end;
  58. end.
复制代码
================================================================
请使用linux系统的朋友测试,这个控件是否也可以在linux里使用。
回复 支持 反对

使用道具 举报

该用户从未签到

发表于 2012-3-8 18:40:48 | 显示全部楼层
ShellExecute 是 WIN32 的一个 API

如果是 LINUX 呢?
回复 支持 反对

使用道具 举报

  • TA的每日心情
    奋斗
    2017-8-16 21:28
  • 签到天数: 6 天

    [LV.2]偶尔看看I

    发表于 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;
    回复 支持 反对

    使用道具 举报

    该用户从未签到

    发表于 2012-4-3 15:19:56 | 显示全部楼层
    请教掌门人:如果用shellexecute打开路径带汉字的文件,该如何写?不知该如何转换
    谢谢
    回复 支持 反对

    使用道具 举报

    该用户从未签到

     楼主 发表于 2012-4-5 14:34:34 | 显示全部楼层
    路径转换过来就可以了: UTF8TOSys(你的路径)
    回复 支持 反对

    使用道具 举报

    该用户从未签到

    发表于 2012-4-7 14:45:24 | 显示全部楼层

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

    逍遥派掌门人:路径转换过来就可以了: UTF8TOSys(你的路径)
     (2012-04-05 14:34) 
    谢谢掌门人
    回复 支持 反对

    使用道具 举报

    该用户从未签到

    发表于 2012-4-25 17:54:51 | 显示全部楼层
    其实这个控件在linux中能否运行关键是看OpenURL(fURL) 这句能否正确执行

    很幸运的是 OpenURL(fURL) 这句在lazarus for linux下可以正确的执行
    回复 支持 反对

    使用道具 举报

    QQ|手机版|小黑屋|Lazarus中国|Lazarus中文社区 ( 鄂ICP备16006501号-1

    GMT+8, 2020-11-30 16:03 , Processed in 0.054723 second(s), 26 queries .

    Powered by Discuz! F1.0 Build 20160930

    © 2001-2020 Comsenz Inc. & Discuz! Fans

    快速回复 返回顶部 返回列表