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

piaoxueboy

//==============================================================================
//                             TTYURLLabel
//
//           版本: v1.00   设计者：田逸    日期：20120428
//
// 功能说明:
//   URL 标签(可以在Lazarus for win, Lazarus for linux使用)
//
//
// 属性说明：
//   1、ColorIn      鼠标移动到标签上时的颜色
//   2、ColorOut     鼠标离开标签时的颜色（可能有点多余）
//   3、MailLabel    标签是邮箱
//   4、Underline    鼠标移动到标签上时，标签文字是否带下划线
//
//
//==============================================================================
unit TYURLLabel;

{$mode objfpc}{$H+}

interface

uses
   LCLINtf, Messages, SysUtils, StdCtrls, Classes, Graphics, Controls, LResources;


{I+}

type

  { TTYURLLabel }

  TTYURLLabel = class(TLabel)
  private
    FMailLabel: Boolean;
    FUnderline: Boolean;

    FColorIn:   TColor;
    FColorOut:  TColor;

    procedure SetFontColorIn(Value: TColor);
    procedure SetFontColorOut(Value: TColor);

    procedure SetMailLabel(Value: Boolean);
    procedure SetUnderLine(Value:Boolean);
  protected
    procedure Click; override;
    procedure MouseEnter; override;
    procedure MouseLeave; override;
  public
    constructor Create(AOwner: TComponent); override;

  published
    property MailLabel: Boolean   read FMailLabel write SetMailLabel;
    property UnderLine: Boolean   read FUnderLine write setUnderLine default True;

    property FontColorin: TColor  read FColorin   write SetFontColorin;
    property FontColorOut: TColor read FColorOut  write SetFontColorOut;

    property OnMouseEnter;
    property OnMouseLeave;
  end;

procedure Register;

implementation


procedure Register;
begin
  RegisterComponents('TianYi', [TTYURLLabel]);
end;


constructor TTYURLLabel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  Cursor:= crHandPoint;
  FColorIn:= clBlue;
  FColorOut:= clBlack;
  FUnderLine:= True;
end;


procedure TTYURLLabel.Click;
begin
  inherited Click;

  if FMailLabel then
    OpenURL('mailto:' + Caption)
  else if Pos('http://', LowerCase(Caption)) <> 1 then
    OpenURL('http://' + Caption)
  else
    OpenURL(Caption);
end;


procedure TTYURLLabel.MouseEnter;
begin
  inherited MouseEnter;

  if not Enabled then Exit;
  Font.Color := FColorIn;

  if FUnderLine then
    Font.Style := Font.Style + [fsUnderline]
  else
    Font.Style := Font.Style - [fsUnderline];
end;


procedure TTYURLLabel.MouseLeave;
begin
  inherited MouseLeave;

  Font.Color := FColorOut;
  Font.Style := Font.Style - [fsUnderline];
end;


procedure TTYURLLabel.SetFontColorIn(Value: TColor);
begin
  if Value <> FColorIn then FColorIn:= Value;
end;


procedure TTYURLLabel.SetFontColorOut(Value: TColor);
begin
  if Value <> FColorout then FColorOut:= Value;
end;


procedure TTYURLLabel.SetMailLabel(Value: Boolean);
begin
  FMailLabel := Value;
end;


procedure TTYURLLabel.SetUnderLine(Value: Boolean);
begin
  if Value <> FUnderLine then FUnderline:= Value
end;


initialization
  {$I tyurllabel.lrs}


end.

bugxiong

Lazarus社区有你更精彩！

逍遥派掌门人

优秀文章，支持！n神马都是浮云！

1234567

请问,调试控件也要编译IDE吗?谢谢

逍遥派掌门人

是的，自动编译了。