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.