Author: Daniel Wischnewski
I have seen many tips on how to call the default browser and open a web page, yet
no component in DKB that allows to simply be placed on a form at design time.
Answer:
This component was developed for the German-language forum
Delphi-PRAXiShttp://www.delphipraxis.net by myself. There is not much to say about
it. Simply copy the source code into a new Delphi unit save it and install the
component in Delphi.
Afterwards you may place it on your form, set link and caption, adjust the colors
for Hot-Link, Visited and Unvisited. Just like a link within your HTML. You may
place a link to an e-mail address also, by simply preceding the email address with
a mailto:.
======================== CODE START ========================
1
2 {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
3 *
4 * Unit Name : uDPLinkLabel
5 * Copyright : Copyright © 2001, 2002 by gate(n)etwork. All Rights Reserved.
6 * Author : Daniel Wischnewski
7 * Freeware : This source is released under the Mozilla Public License. It may
8 * be reproduced, as long as all references to its original source
9 * are maintained.
10 * The most recent version is publicly available at
11 * http://www.Delphi-PRAXiS.net
12 *
13 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
14
15 //: Enthält eine Internetlink-Label-Komponente für die Mitglieder der Delphi-PRAXiS.
16 unit uDPLinkLabel;
17
18 interface
19
20 uses
21 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
22 StdCtrls;
23
24 type
25 //: Komponente zur Bereitstellung von Links innerhalb von Delphi-Anwendungen
26 TDPLinkLabel = class(TCustomLabel)
27 private
28 FHoverLinkFont: TFont;
29 FHyperLink: string;
30 FLinkFont: TFont;
31 FMouseHover: Boolean;
32 FVisited: Boolean;
33 FVisitedLinkFont: TFont;
34 procedure FontChanged(Sender: TObject);
35 procedure SetHoverLinkFont(Value: TFont);
36 procedure SetHyperLink(Value: string);
37 procedure SetLinkFont(Value: TFont);
38 procedure SetVisited(Value: Boolean);
39 procedure SetVisitedLinkFont(Value: TFont);
40 procedure UpdateLinkFont;
41 protected
42 procedure Click; override;
43 procedure CMMouseEnter(var message: TMessage); message CM_MOUSEENTER;
44 procedure CMMouseLeave(var message: TMessage); message CM_MOUSELEAVE;
45 public
46 constructor Create(AOwner: TComponent); override;
47 destructor Destroy; override;
48 procedure ExecuteHyperLink(aLink: string = '');
49 published
50 property Align;
51 property Alignment;
52 property Anchors;
53 property AutoSize;
54 property BiDiMode;
55 property Caption;
56 property Color;
57 property Constraints;
58 property DragCursor;
59 property DragKind;
60 property DragMode;
61 property Enabled;
62 property FocusControl;
63 property HoverLinkFont: TFont read FHoverLinkFont write SetHoverLinkFont;
64 property HyperLink: string read FHyperLink write SetHyperLink;
65 property Layout;
66 property LinkFont: TFont read FLinkFont write SetLinkFont;
67 property OnClick;
68 property OnContextPopup;
69 property OnDblClick;
70 property OnDragDrop;
71 property OnDragOver;
72 property OnEndDock;
73 property OnEndDrag;
74 property OnMouseDown;
75 property OnMouseMove;
76 property OnMouseUp;
77 property OnStartDock;
78 property OnStartDrag;
79 property ParentBiDiMode;
80 property ParentColor;
81 property ParentShowHint;
82 property PopupMenu;
83 property ShowAccelChar;
84 property ShowHint;
85 property Transparent;
86 property Visible;
87 property Visited: Boolean read FVisited write SetVisited;
88 property VisitedLinkFont: TFont read FVisitedLinkFont write
89 SetVisitedLinkFont;
90 property WordWrap;
91 end;
92
93 procedure register;
94
95 implementation
96
97 uses
98 ShellAPI;
99
100 procedure register;
101 begin
102 RegisterComponents('Delphi-PRAXiS', [TDPLinkLabel]);
103 end;
104
105 { TDPLinkLabel }
106
107 constructor TDPLinkLabel.Create(AOwner: TComponent);
108 begin
109 inherited Create(AOwner);
110 // create default link font object
111 FLinkFont := TFont.Create;
112 FLinkFont.OnChange := FontChanged;
113 FLinkFont.Color := clBlue;
114 FLinkFont.Style := [fsUnderline];
115 // set inherited font
116 Font := LinkFont;
117 // create visit link font object
118 FVisitedLinkFont := TFont.Create;
119 FVisitedLinkFont.OnChange := FontChanged;
120 FVisitedLinkFont.Color := clPurple;
121 FVisitedLinkFont.Style := [fsUnderline];
122 // create hover link font object
123 FHoverLinkFont := TFont.Create;
124 FHoverLinkFont.OnChange := FontChanged;
125 FHoverLinkFont.Color := clRed;
126 FHoverLinkFont.Style := [fsUnderline];
127 // initialize vars
128 FMouseHover := False;
129 FVisited := False;
130 Caption := 'Delphi-PRAXiS';
131 FHyperLink := 'http://www.Delphi-PRAXiS.net';
132 // override initialization of previous vars
133 Cursor := crHandPoint;
134 end;
135
136 destructor TDPLinkLabel.Destroy;
137 begin
138 inherited Destroy;
139 // free link font objects
140 FLinkFont.Free;
141 FHoverLinkFont.Free;
142 FVisitedLinkFont.Free;
143 end;
144
145 procedure TDPLinkLabel.Click;
146 begin
147 // the onClick method will be overriden only, if a link is assigned to the
148 // Link property of the component and no custom on-click handler is assigned
149 if (not Assigned(OnClick)) and (Action = nil) and (ActionLink = nil) and (
150 HyperLink <> '') then
151 // call link
152 ExecuteHyperLink
153 else
154 // work standard control click routine
155 inherited;
156 end;
157
158 procedure TDPLinkLabel.CMMouseEnter(var message: TMessage);
159 begin
160 inherited;
161 // mouse enters link - hover color effective
162 FMouseHover := True;
163 UpdateLinkFont;
164 end;
165
166 procedure TDPLinkLabel.CMMouseLeave(var message: TMessage);
167 begin
168 inherited;
169 // mouse leaves link - hover color not effective anymore
170 FMouseHover := False;
171 UpdateLinkFont;
172 end;
173
174 procedure TDPLinkLabel.ExecuteHyperLink(aLink: string = '');
175 var
176 UseLink: string;
177 begin
178 // set link for execution
179 if Trim(aLink) = '' then
180 UseLink := Trim(HyperLink)
181 else
182 UseLink := Trim(aLink);
183 // check link data
184 if Trim(UseLink) = '' then
185 // raise exception on empty link
186 raise Exception.Create('No link for launching web browser.');
187 // load default browser with link
188 ShellExecute(0, nil, PChar(HyperLink), nil, nil, SW_SHOW);
189 // HyperLink was visited, no special link passed
190 if Trim(aLink) <> '' then
191 Visited := True;
192 end;
193
194 procedure TDPLinkLabel.FontChanged(Sender: TObject);
195 begin
196 // need to inform preceding class of possible changes in font
197 UpdateLinkFont;
198 end;
199
200 procedure TDPLinkLabel.SetHoverLinkFont(Value: TFont);
201 begin
202 FHoverLinkFont.Assign(Value);
203 UpdateLinkFont;
204 end;
205
206 procedure TDPLinkLabel.SetHyperLink(Value: string);
207 begin
208 if FHyperLink <> Value then
209 begin
210 FHyperLink := Value;
211 Visited := False;
212 if Caption = '' then
213 Caption := HyperLink;
214 end;
215 end;
216
217 procedure TDPLinkLabel.SetLinkFont(Value: TFont);
218 begin
219 FLinkFont.Assign(Value);
220 UpdateLinkFont;
221 end;
222
223 procedure TDPLinkLabel.SetVisited(Value: Boolean);
224 begin
225 if FVisited <> Value then
226 begin
227 FVisited := Value;
228 UpdateLinkFont;
229 end;
230 end;
231
232 procedure TDPLinkLabel.SetVisitedLinkFont(Value: TFont);
233 begin
234 FVisitedLinkFont.Assign(Value);
235 UpdateLinkFont;
236 end;
237
238 procedure TDPLinkLabel.UpdateLinkFont;
239 begin
240 // assign font property the appropriate font data
241 if FMouseHover then
242 Font := HoverLinkFont
243 else if Visited then
244 Font := VisitedLinkFont
245 else
246 Font := LinkFont;
247 end;
248
249 end.
========================= CODE END =========================
|
