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
|
{
fpGUI - Free Pascal GUI Toolkit
Copyright (C) 2006 - 2008 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 gui_hyperlink;
{$mode objfpc}{$H+}
interface
uses
Classes,
Sysutils,
gui_label,
fpgfx,
gfxbase;
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 Autosize;
property FontDesc;
property HotTrackColor: TfpgColor read fHotTrackColor write SetHotTrackColor;
property HotTrackFont: TfpgString read fHTFont write SetHotTrackFont;
property Text;
property TextColor;
property URL: TfpgString read FUrl write SetURL;
property OnClick;
end;
implementation
uses
gfx_utils;
{ TfpgHyperlink }
constructor TfpgHyperlink.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fHotTrackColor := clBlue;
TextColor := clBlue;
fUrl := 'http://opensoft.homeip.net/fpgui/';
Text := 'fpGUI website';
fHTFont := 'Arial-8:antialias=true:underline:bold';
FontDesc := 'Arial-8:antialias=true:underline';
AutoSize := True;
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.
|
