unit HyperLink;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  StdCtrls;

type
  THyperLink = class(TLabel)
  private
    FMove: Boolean;
    FActiveColor: TColor;
    FACR: Byte;
    FACG: Byte;
    FACB: Byte;
    procedure WMMouseMove(var Message: TWMMove); message WM_MOUSEMOVE;
    procedure SetAC(C: TColor);
    procedure SetACRed(Red: Byte);
    procedure SetACGreen(Red: Byte);
    procedure SetACBlue(Red: Byte);
  protected
    procedure WndProc(var Message: TMessage); override;
    procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Paint; override;
  published
    property ActiveColor : TColor read FActiveColor write SetAC;
    property ActiveColorRed : Byte read FACR write SetACRed;
    property ActiveColorGreen : Byte read FACG write SetACGreen;
    property ActiveColorBlue : Byte read FACB write SetACBlue;
  end;

  TLinkLabel = class(TLabel)
  private
    FMove: Boolean;
    FActiveColor: TColor;
    FACR: Byte;
    FACG: Byte;
    FACB: Byte;
    procedure WMMouseMove(var Message: TWMMove); message WM_MOUSEMOVE;
    procedure SetAC(C: TColor);
    procedure SetACRed(Red: Byte);
    procedure SetACGreen(Red: Byte);
    procedure SetACBlue(Red: Byte);
  protected
    procedure WndProc(var Message: TMessage); override;
    procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Paint; override;
  published
    property ActiveColor : TColor read FActiveColor write SetAC;
    property ActiveColorRed : Byte read FACR write SetACRed;
    property ActiveColorGreen : Byte read FACG write SetACGreen;
    property ActiveColorBlue : Byte read FACB write SetACBlue;
  end;

  TShadowLabel = class(TCustomLabel)
  private
    FShadowColor: TColor;
    FSE:          Boolean;
    procedure SetFSE(SE: Boolean);
    procedure SetSColor(C: TColor);
  protected
    procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
  public
    constructor Create(AOwner: TComponent); override;
  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 Font;
    property ParentBiDiMode;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowAccelChar;
    property ShowHint;
    property ShadowColor: TColor read FShadowColor write SetSColor;
    property ShadowEnabled: Boolean read FSE write SetFSE;
    property Transparent;
    property Layout;
    property Visible;
    property WordWrap;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('PS-Soft', [THyperLink, TLinkLabel, TShadowLabel]);
end;

(* THyperLink *)

procedure THyperLink.SetAC(C: TColor);
begin
  fActiveColor := C;
  FACR := GetRValue(C);
  FACG := GetGValue(C);
  FACB := GetBValue(C);
end;

procedure THyperLink.SetACRed(Red: Byte);
begin
  FACR := Red;
  ActiveColor := RGB(FACR, FACG, FACB);
end;

procedure THyperLink.SetACGreen(Red: Byte);
begin
  FACG := Red;
  ActiveColor := RGB(FACR, FACG, FACB);
end;

procedure THyperLink.SetACBlue(Red: Byte);
begin
  FACB := Red;
  ActiveColor := RGB(FACR, FACG, FACB);
end;

procedure THyperLink.Paint;
const
  Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
var
  Rect, CalcRect: TRect;
  DrawStyle: Longint;
begin
  with Canvas do
  begin
    if not Transparent then
    begin
      Brush.Color := Self.Color;
      Brush.Style := bsSolid;
      FillRect(ClientRect);
    end;
    Brush.Style := bsClear;
    Rect := ClientRect;
    { DoDrawText takes care of BiDi alignments }
    DrawStyle := DT_EXPANDTABS or WordWraps[WordWrap] or Alignments[Alignment];
    { Calculate vertical layout }
    if Layout <> tlTop then
    begin
      CalcRect := Rect;
      DoDrawText(CalcRect, DrawStyle or DT_CALCRECT);
      if Layout = tlBottom then OffsetRect(Rect, 0, Height - CalcRect.Bottom)
      else OffsetRect(Rect, 0, (Height - CalcRect.Bottom) div 2);
    end;
    DoDrawText(Rect, DrawStyle);
  end;
end;

procedure THyperLink.DoDrawText(var Rect: TRect; Flags: Longint);
var
  Text: string;
begin
  Text := GetLabelText;
  if (Flags and DT_CALCRECT <> 0) and ((Text = '') or ShowAccelChar and
    (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' ';
  if not ShowAccelChar then Flags := Flags or DT_NOPREFIX;
  Flags := DrawTextBiDiModeFlags(Flags);
  Canvas.Font := Font;
  if not Enabled then
  begin
    OffsetRect(Rect, 1, 1);
    Canvas.Font.Color := clBtnHighlight;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
    OffsetRect(Rect, -1, -1);
    Canvas.Font.Color := clBtnShadow;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
  end
  else
    begin
      if FMove then
      begin
        Canvas.Font.Color := fActiveColor;
        Font.Style := [fsUnderline];
        DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
      end
        else
          begin
            Font.Style := [fsUnderLine];
            DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
          end;
    end;
end;

constructor THyperLink.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  MouseCapture := True;
  FMove := False;
end;

procedure THyperLink.WndProc(var Message: TMessage);
begin
  inherited;
  if Message.Msg = 45076 then
    if FMove <> False then
    begin
      FMove := False;
      Repaint;
    end;
end;

procedure THyperLink.WMMouseMove(var Message: TWMMove);
begin
  if FMove <> True then
  begin
    FMove := True;
    Cursor := crHandPoint;
    Repaint;
  end;
end;

(* TLinkLabel *)

procedure TLinkLabel.SetAC(C: TColor);
begin
  fActiveColor := C;
  FACR := GetRValue(C);
  FACG := GetGValue(C);
  FACB := GetBValue(C);
end;

procedure TLinkLabel.SetACRed(Red: Byte);
begin
  FACR := Red;
  ActiveColor := RGB(FACR, FACG, FACB);
end;

procedure TLinkLabel.SetACGreen(Red: Byte);
begin
  FACG := Red;
  ActiveColor := RGB(FACR, FACG, FACB);
end;

procedure TLinkLabel.SetACBlue(Red: Byte);
begin
  FACB := Red;
  ActiveColor := RGB(FACR, FACG, FACB);
end;

procedure TLinkLabel.Paint;
const
  Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
var
  Rect, CalcRect: TRect;
  DrawStyle: Longint;
begin
  with Canvas do
  begin
    if not Transparent then
    begin
      Brush.Color := Self.Color;
      Brush.Style := bsSolid;
      FillRect(ClientRect);
    end;
    Brush.Style := bsClear;
    Rect := ClientRect;
    { DoDrawText takes care of BiDi alignments }
    DrawStyle := DT_EXPANDTABS or WordWraps[WordWrap] or Alignments[Alignment];
    { Calculate vertical layout }
    if Layout <> tlTop then
    begin
      CalcRect := Rect;
      DoDrawText(CalcRect, DrawStyle or DT_CALCRECT);
      if Layout = tlBottom then OffsetRect(Rect, 0, Height - CalcRect.Bottom)
      else OffsetRect(Rect, 0, (Height - CalcRect.Bottom) div 2);
    end;
    DoDrawText(Rect, DrawStyle);
  end;
end;

procedure TLinkLabel.DoDrawText(var Rect: TRect; Flags: Longint);
var
  Text: string;
begin
  Text := GetLabelText;
  if (Flags and DT_CALCRECT <> 0) and ((Text = '') or ShowAccelChar and
    (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' ';
  if not ShowAccelChar then Flags := Flags or DT_NOPREFIX;
  Flags := DrawTextBiDiModeFlags(Flags);
  Canvas.Font := Font;
  if not Enabled then
  begin
    OffsetRect(Rect, 1, 1);
    Canvas.Font.Color := clBtnHighlight;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
    OffsetRect(Rect, -1, -1);
    Canvas.Font.Color := clBtnShadow;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
  end
  else
    begin
      if FMove then
      begin
        Canvas.Font.Color := fActiveColor;
        Font.Style := [fsUnderline];
        DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
      end
        else
          begin
            Font.Style := [];
            DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
          end;
    end;
end;

constructor TLinkLabel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  MouseCapture := True;
  FMove := False;
end;

procedure TLinkLabel.WndProc(var Message: TMessage);
begin
  inherited;
  if Message.Msg = 45076 then
    if FMove <> False then
    begin
      FMove := False;
      Repaint;
    end;
end;

procedure TLinkLabel.WMMouseMove(var Message: TWMMove);
begin
  if FMove <> True then
  begin
    FMove := True;
    Cursor := crHandPoint;
    Repaint;
  end;
end;

(* TShadowLabel *)

constructor TShadowLabel.Create(AOwner: TComponent);
begin
  FShadowColor := clGray;
  FSE := True;
  inherited Create(AOwner);
end;

procedure TShadowLabel.SetFSE(SE: Boolean);
begin
  if SE <> FSE then
  begin
    FSE := SE;
    ReFresh;
  end;
end;

procedure TShadowLabel.SetSColor(C: TColor);
begin
  if FShadowColor <> C then
  begin
    FShadowColor := C;
    ReFresh;
  end;
end;

procedure TShadowLabel.DoDrawText(var Rect: TRect; Flags: Longint);
var
  Text: string;
begin
  Text := GetLabelText;
  if (Flags and DT_CALCRECT <> 0) and ((Text = '') or ShowAccelChar and
    (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' ';
  if not ShowAccelChar then Flags := Flags or DT_NOPREFIX;
  Flags := DrawTextBiDiModeFlags(Flags);
  Canvas.Font := Font;
  if not Enabled then
  begin
    OffsetRect(Rect, 1, 1);
    Canvas.Font.Color := clBtnHighlight;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
    OffsetRect(Rect, -1, -1);
    Canvas.Font.Color := clBtnShadow;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
  end
    else
      begin
        OffsetRect(Rect, 1, 1);
        Canvas.Font.Color := FShadowColor;
        if FSE then
        begin
          DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
        end;
        Canvas.Font.Color := Font.Color;
        OffsetRect(Rect, -1, -1);
        DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
      end;
end;

end.