hyperlink.pas

此软件支持多文档打开

{Enhanced by Xueyu,LEE([e-mail])}
{Add property Transparent}

{ Copyright (C) 1998 BPG, T鮥vo Leedj鋜v                                   }
{ Autori e-mail: [e-mail]                                      }
{ All rights reserved. K鮥k 鮥gused reserveeritud.                         }
{ Koodi ei tohi mitte mingil kujul ilma autori loata                       }
{ kasutada ei kommertslikel ega ka muudel eesm鋜kidel.                     }
{                                                                          }
{ THyperLink - H黳erlinkide komponent                                      }
{                                                                          }
{ Thanks to Klaus Meyer who added some features.                           }
{                                                                          }
{ Version Kuup.     Kirj.                                                  }
{ 0.1.1   6.05.98   Esimene versioon. T鲻tab kah isegi. N鋓tab HREFi       }
{                   StatusBaril ja puha.                                   }
{ 0.2.2   5.06.98   Fixed a nasty bug...pressing Enter while THyperLink    }
{                   had focus did nth.                                     }
{ 0.3.3   6.08.98   Klaus Meyer ([e-mail]) added OnExit, OverColor }
{                   and some other minor things                            }

{ 0.3.4   1998      Enhanced by Xueyu,LEE                                  }
{                     Add property Transparent                             }
{ 0.3.5   2000      Enhanced by Basri Kanca                                }
{                     Altered various color stuff                          }

Unit HyperLink;

Interface

Uses
  Windows,
  Messages,
  SysUtils,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  StdCtrls,
  ComCtrls;
Type
  TColors = Class(TPersistent)
  Private
    FPressed: TColor;
    FReleased: TColor;
    FHoovered: TColor;
  Public
    Constructor Create;
  Published
    Property Pressed: TColor Read FPressed Write FPressed Default clRed;
    Property Released: TColor Read FReleased Write FReleased Default clBlue;
    Property Hoovered: TColor Read FHoovered Write FHoovered Default clGreen;
  End;

  THyperLink = Class(TLabel)
  Private
    FActive: Boolean;
    FHREF: String;
    //FColors.Released: TColor;
    //FColorMouseOver: TColor;
    //FColorPressed: TColor;
    FDown: Boolean;
    FOver: Boolean;
    FCursor, FStatusNr: Integer;
    FStatusBar: TStatusBar;
    FColors: TColors;
    Procedure CMFontChanged(Var Message: TMessage); Message CM_FONTCHANGED;
    Procedure CMTextChanged(Var Message: TMessage); Message CM_TEXTCHANGED;
    Procedure CMMouseLeave(Var Message: TMessage); Message CM_MOUSELEAVE;
    Procedure AdjustBounds; Reintroduce;
  Protected
    Procedure Loaded; Override;
    Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override;
    Procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override;
    Procedure MouseMove(Shift: TShiftState; X, Y: Integer); Override;
    Procedure SetHLinkStyle(AActive: Boolean);
  Public
    Constructor Create(AOwner: TComponent); Override;
  Published
    Property Height Default 14;
    Property Width Default 55;
    Property AutoSize Default True;
    Property Caption;
    Property Color Default ClSilver;
    Property Enabled;
    Property Font;
    Property HRef: String Read FHREF Write FHREF;
    Property ParentColor;
    Property ParentFont;
    Property ParentShowHint;
    Property PopupMenu;
    Property ShowHint;
    Property StatusBar: TStatusBar Read FStatusBar Write FStatusBar;
    Property StatusPanelNo: Integer Read FStatusNr Write FStatusNr;
    Property Visible;
    Property OnClick;
    Property OnDblClick;
    Property OnDragOver;
    Property OnMouseDown;
    Property OnMouseMove;
    Property OnMouseUp;
    Property Colors: TColors Read FColors Write FColors;
  End;

Procedure Register;

Implementation

Uses
  SynEditStrConst,
  ShellAPI;

{$R HyperLinkCursor.res}

Procedure Register;
Begin
  RegisterComponents(SYNS_ComponentsPage, [THyperLink]);
End;

Constructor TColors.Create;
Begin
  Inherited Create;
  FPressed := clRed;
  FReleased := clBlue;
  FHoovered := clGreen;
End;

Constructor THyperLink.Create(AOwner: TComponent);
Begin
  Inherited Create(AOwner);
  FColors := TColors.Create;
  ShowAccelChar := False;
  Width := 55;
  Height := 14;
  FActive := False;
  FCursor := CrHandPoint;
  FDown := False;
  FOver := False;
  FColors.Released := clBlue;
  FColors.Pressed := clRed;
  FColors.Hoovered := clGreen;
  //Color := ClSilver;
  Font.Color := FColors.Released;
  Font.Style := Font.Style + [FsUnderLine];
  Screen.Cursors[FCursor] := LoadCursor(HInstance, 'NETSCCUR');
  Cursor := FCursor;
  AdjustBounds;
End;

Procedure THyperLink.CMFontChanged(Var Message: TMessage);
Begin
  Inherited;
  If (Font.Color <> FColors.Released) And (Not FDown) And (Not FOver) Then FColors.Released := Font.Color;
  AdjustBounds;
End;

Procedure THyperLink.CMTextChanged(Var Message: TMessage);
Begin
  Inherited;
  AdjustBounds;
End;

Procedure THyperLink.CMMouseLeave(Var Message: TMessage);
Begin
  Inherited;
  If FOver And Enabled {and not FDragging} Then Begin
    FOver := False;
    Font.Color := FColors.Released;
    InValidate;
  End;
End;

Procedure THyperLink.AdjustBounds;
Var
  DC: HDc;
  SaveFont: HFont;
  TextSize: TSize;
Begin
  If Not (CsReading In ComponentState) Then Begin
    DC := GetDC(0);
    SaveFont := SelectObject(DC, Font.Handle);
    GetTextExtentPoint32(DC, PChar(Caption), Length(Caption), TextSize);
    If (Font.Name <> 'MS Sans Serif') And (FsItalic In Font.Style) Then GetTextExtentPoint32(DC, PChar(Caption + ','), Length(Caption) + 1, TextSize);
    SelectObject(DC, SaveFont);
    ReleaseDC(0, DC);
    SetBounds(Left, Top, TextSize.cx + (GetSystemMetrics(SM_CXBORDER) * 1), TextSize.cy + (GetSystemMetrics(SM_CYBORDER) * 1));
  End;
End;

Procedure THyperLink.Loaded;
Begin
  Inherited Loaded;
  AdjustBounds;
End;

Procedure THyperLink.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
Begin
  If Button = MbLeft Then Begin
    FDown := True;
    FOver := False;
    If Not (CsDesigning In ComponentState) Then Font.Color := FColors.Pressed;
  End;
  Inherited;
End;

Procedure THyperLink.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
Begin
  FDown := False;
  Font.Color := FColors.Released;
  Inherited;
  InValidate;
  Application.ProcessMessages;
  If (X In [0..Width]) And (Y In [0..Height]) And (FHREF <> '') And (Button = MbLeft) Then ShellExecute($80, 'open', PChar(FHREF), '', '', SW_SHOWDEFAULT);
End;

Procedure THyperLink.MouseMove(Shift: TShiftState; X, Y: Integer);
Var
  s: String;
Begin
  Inherited;
  If (FStatusBar <> Nil) And ((X <= Width) And (Y <= Height)) Then Begin
    s := FStatusBar.Panels[FStatusNr].Text;
    FStatusBar.Panels[FStatusNr].Text := FHREF;
  End;

  If (SsLeft In Shift) Or (SsMiddle In Shift) Then Begin
    If Not ((X In [0..Width]) And (Y In [0..Height])) Then Begin
      If FActive <> False Then Begin
        FActive := False;
        SetHLinkStyle(FActive);
      End;
    End Else If FActive <> True Then Begin
      FActive := True;
      SetHLinkStyle(FActive);
    End;
  End Else Begin
    FDown := False;
    FOver := True;
    Font.Color := FColors.FHoovered;
  End;
End;

Procedure THyperLink.SetHLinkStyle(AActive: Boolean);
Begin
  Case AActive Of
    True: Begin
        FDown := True;
        Font.Color := FColors.Pressed;
      End;
    False: Begin
        FDown := False;
        Font.Color := FColors.Released;
      End;
  End;
  Perform(WM_PAINT, 0, 0);
End;

End.