1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
{
fpGUI - Free Pascal GUI Toolkit
Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this
distribution, for details of the copyright.
See the file COPYING.modifiedLGPL, included in this distribution,
for details about redistributing fpGUI.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Description:
A hyperlink label component. When the user clicks the label, a
web browser is opened with the URL specified.
}
unit fpg_hyperlink;
{$mode objfpc}{$H+}
interface
uses
Classes,
Sysutils,
fpg_base,
fpg_main,
fpg_label;
type
TfpgHyperlink = class(TfpgCustomLabel)
private
FHotTrackColor: TfpgColor;
FOldColor: TfpgColor;
FOldFont: TfpgString;
FHTFont: TfpgString;
FUrl: TfpgString;
procedure SetHotTrackColor(const AValue: TfpgColor);
procedure SetHotTrackFont(const AValue: TfpgString);
procedure SetURL(const Value: TfpgString);
protected
procedure HandleMouseEnter; override;
procedure HandleMouseExit; override;
procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override;
public
constructor Create(AOwner: TComponent); override;
procedure GoHyperLink;
published
property Align;
property Alignment;
property Autosize;
property BackgroundColor;
property Enabled;
property FontDesc;
property Height;
property Hint;
property HotTrackColor: TfpgColor read FHotTrackColor write SetHotTrackColor default clHyperLink;
property HotTrackFont: TfpgString read FHTFont write SetHotTrackFont;
property Layout;
property Left;
property Parent;
property ParentShowHint;
property ShowHint;
property Text;
property TextColor default clHyperLink;
property URL: TfpgString read FUrl write SetURL;
property Top;
property Width;
property WrapText;
property OnClick;
property OnShowHint;
end;
implementation
uses
fpg_utils
,fpg_constants
;
{ TfpgHyperlink }
constructor TfpgHyperlink.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 120;
FHotTrackColor := clHyperLink;
TextColor := clHyperLink;
FUrl := fpGUIWebsite;
FText := 'fpGUI website';
FHTFont := FPG_DEFAULT_SANS + '-8:antialias=true:underline:bold';
FontDesc := FPG_DEFAULT_SANS + '-8:antialias=true:underline';
end;
procedure TfpgHyperlink.SetURL(const Value: TfpgString);
begin
if FUrl <> Value then
FUrl := Value;
end;
procedure TfpgHyperlink.SetHotTrackFont(const AValue: TfpgString);
begin
if FHTFont = AValue then
Exit;
FHTFont := AValue;
end;
procedure TfpgHyperlink.SetHotTrackColor(const AValue: TfpgColor);
begin
if FHotTrackColor = AValue then
Exit;
FHotTrackColor := AValue;
end;
procedure TfpgHyperlink.GoHyperLink;
begin
if URL <> '' then
fpgOpenURL(URL);
end;
procedure TfpgHyperlink.HandleMouseEnter;
begin
inherited HandleMouseEnter;
FOldColor := TextColor;
TextColor := FHotTrackColor;
FOldFont := FontDesc;
FontDesc := FHTFont;
MouseCursor := mcHand;
end;
procedure TfpgHyperlink.HandleMouseExit;
begin
inherited HandleMouseExit;
TextColor := FOldColor;
MouseCursor := mcDefault;
FontDesc := FOldFont;
end;
procedure TfpgHyperlink.HandleLMouseDown(x, y: integer; shiftstate: TShiftState);
begin
inherited HandleLMouseDown(x, y, shiftstate);
if not Assigned(OnClick) then
GoHyperlink;
end;
end.
|
