This component was developed for the German-language forum
Delphi-PRAXiS 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 ========================
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
* Unit Name : uDPLinkLabel
* Copyright : Copyright © 2001, 2002 by gate(n)etwork. All Rights Reserved.
* Author : Daniel Wischnewski
* Freeware : This source is released under the Mozilla Public License. It may
* be reproduced, as long as all references to its original source
* are maintained.
* The most recent version is publicly available at
* http://www.Delphi-PRAXiS.net
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
//: Enthält eine Internetlink-Label-Komponente für die Mitglieder der Delphi-PRAXiS.
unit uDPLinkLabel;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
//: Komponente zur Bereitstellung von Links innerhalb von Delphi-Anwendungen
TDPLinkLabel =
class (TCustomLabel)
private
FHoverLinkFont: TFont;
FHyperLink:
string;
FLinkFont: TFont;
FMouseHover: Boolean;
FVisited: Boolean;
FVisitedLinkFont: TFont;
procedure FontChanged(Sender: TObject);
procedure SetHoverLinkFont(Value: TFont);
procedure SetHyperLink(Value:
string);
procedure SetLinkFont(Value: TFont);
procedure SetVisited(Value: Boolean);
procedure SetVisitedLinkFont(Value: TFont);
procedure UpdateLinkFont;
protected
procedure Click;
override;
procedure CMMouseEnter(
var Message: TMessage);
message CM_MOUSEENTER;
procedure CMMouseLeave(
var Message: TMessage);
message CM_MOUSELEAVE;
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
procedure ExecuteHyperLink(aLink:
String =
'');
published
property Align;
property Alignment;
property Anchors;
property AutoSize;
property BiDiMode;
property Caption;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FocusControl;
property HoverLinkFont: TFont
read FHoverLinkFont
write SetHoverLinkFont;
property HyperLink:
string read FHyperLink
write SetHyperLink;
property Layout;
property LinkFont: TFont
read FLinkFont
write SetLinkFont;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
property ParentBiDiMode;
property ParentColor;
property ParentShowHint;
property PopupMenu;
property ShowAccelChar;
property ShowHint;
property Transparent;
property Visible;
property Visited: Boolean
read FVisited
write SetVisited;
property VisitedLinkFont: TFont
read FVisitedLinkFont
write
SetVisitedLinkFont;
property WordWrap;
end;
procedure Register;
implementation
uses
ShellAPI;
procedure Register;
begin
RegisterComponents(
'Delphi-PRAXiS', [TDPLinkLabel]);
end;
{ TDPLinkLabel }
constructor TDPLinkLabel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// create default link font object
FLinkFont := TFont.Create;
FLinkFont.OnChange := FontChanged;
FLinkFont.Color := clBlue;
FLinkFont.Style := [fsUnderline];
// set inherited font
Font := LinkFont;
// create visit link font object
FVisitedLinkFont := TFont.Create;
FVisitedLinkFont.OnChange := FontChanged;
FVisitedLinkFont.Color := clPurple;
FVisitedLinkFont.Style := [fsUnderline];
// create hover link font object
FHoverLinkFont := TFont.Create;
FHoverLinkFont.OnChange := FontChanged;
FHoverLinkFont.Color := clRed;
FHoverLinkFont.Style := [fsUnderline];
// initialize vars
FMouseHover := False;
FVisited := False;
Caption :=
'Delphi-PRAXiS';
FHyperLink :=
'http://www.Delphi-PRAXiS.net';
// override initialization of previous vars
Cursor := crHandPoint;
end;
destructor TDPLinkLabel.Destroy;
begin
inherited Destroy;
// free link font objects
FLinkFont.Free;
FHoverLinkFont.Free;
FVisitedLinkFont.Free;
end;
procedure TDPLinkLabel.Click;
begin
// the onClick method will be overriden only, if a link is assigned to the
// Link property of the component and no custom on-click handler is assigned
if (
not Assigned(OnClick))
and (Action =
nil)
and (ActionLink =
nil)
and (
HyperLink <>
'')
then
// call link
ExecuteHyperLink
else
// work standard control click routine
inherited;
end;
procedure TDPLinkLabel.CMMouseEnter(
var Message: TMessage);
begin
inherited;
// mouse enters link - hover color effective
FMouseHover := True;
UpdateLinkFont;
end;
procedure TDPLinkLabel.CMMouseLeave(
var Message: TMessage);
begin
inherited;
// mouse leaves link - hover color not effective anymore
FMouseHover := False;
UpdateLinkFont;
end;
procedure TDPLinkLabel.ExecuteHyperLink(aLink:
String =
'');
var
UseLink:
string;
begin
// set link for execution
if Trim(aLink) =
'' then
UseLink := Trim(HyperLink)
else
UseLink := Trim(aLink);
// check link data
if Trim(UseLink) =
'' then
// raise exception on empty link
raise Exception.Create(
'No link for launching web browser.');
// load default browser with link
ShellExecute(
0,
nil, PChar(HyperLink),
nil,
nil, SW_SHOW);
// HyperLink was visited, no special link passed
if Trim(aLink) <>
'' then
Visited := True;
end;
procedure TDPLinkLabel.FontChanged(Sender: TObject);
begin
// need to inform preceding class of possible changes in font
UpdateLinkFont;
end;
procedure TDPLinkLabel.SetHoverLinkFont(Value: TFont);
begin
FHoverLinkFont.Assign(Value);
UpdateLinkFont;
end;
procedure TDPLinkLabel.SetHyperLink(Value:
string);
begin
if FHyperLink <> Value
then
begin
FHyperLink := Value;
Visited := False;
if Caption =
'' then
Caption := HyperLink;
end;
end;
procedure TDPLinkLabel.SetLinkFont(Value: TFont);
begin
FLinkFont.Assign(Value);
UpdateLinkFont;
end;
procedure TDPLinkLabel.SetVisited(Value: Boolean);
begin
if FVisited <> Value
then
begin
FVisited := Value;
UpdateLinkFont;
end;
end;
procedure TDPLinkLabel.SetVisitedLinkFont(Value: TFont);
begin
FVisitedLinkFont.Assign(Value);
UpdateLinkFont;
end;
procedure TDPLinkLabel.UpdateLinkFont;
begin
// assign font property the appropriate font data
if FMouseHover
then
Font := HoverLinkFont
else if Visited
then
Font := VisitedLinkFont
else
Font := LinkFont;
end;
end.
========================= CODE END =========================
Regards,
Daniel Wischnewski
Delphi-PRAXiS
Sign Up
