linklabel.pas

Delphi VCL Component Pack

//***********************************************************
//                         TLinkLabel                       *
//                                                          *
//                    For Delphi 5 to 2006                  *
//                     Freeware Component                   *
//                            by                            *
//                     Eran Bodankin (bsalsa)               *                                                            //                   [e-mail]                  *
//                                                          *
//  Documentation and updated versions:                     *
//                                                          *
//               http://www.bsalsa.com                      *
//***********************************************************
{*******************************************************************************}
{LICENSE:
THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
AND DOCUMENTATION. [YOUR NAME] DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. VSOFT SPECIFICALLY
DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.

You may use, change or modify the component under 3 conditions:
1. In your website, add a link to "http://www.bsalsa.com"
2. In your application, add credits to "Embedded Web Browser"
3. Mail me  ([e-mail]) any code change in the unit
   for the benefit of the other users.
{*******************************************************************************}

unit LinkLabel;

interface

{$I EWB.inc}

uses
   SysUtils, Windows, ExtCtrls, Dialogs, Controls, StdCtrls, Messages, Classes,
   Graphics, Menus, ImgList;

type
   TDirection = (diLeftToRight, diRightToLeft, diTopToBottom, diBottomToTop);
   TTextStyle = (tsNormal, ts3D_F, ts3D_B);
   TTextLayout = (tlTop, tlCenter, tlBottom);
   TLaunchSettings = (Http, MailTo, Application);
   TWindowState = (wsNormal, wsMinimized, wsMaximized);
   TOnLaunchEvent = procedure(var Successs: Boolean; const ErrorText: string; var Result: Cardinal) of object;
   TTextEffects = (teNormal, teRunning, teFlickering);
//------------------------------------------------------------------------------
   TMail = class(TPersistent)
   private
      FAddress: AnsiString;
      FSubject: AnsiString;
      FBody: AnsiString;
      FWindowState: TWindowState;
   published
      property Address: AnsiString read FAddress write FAddress;
      property Subject: AnsiString read FSubject write FSubject;
      property Body: AnsiString read FBody write FBody;
      property WindowState: TWindowState read FWindowState write FWindowState default wsNormal;
   end;

   THttp = class(TPersistent)
   private
      FAddress: AnsiString;
      FWindowState: TWindowState;
      procedure SetAddress(value: AnsiString);
   published
      property Address: AnsiString read FAddress write SetAddress;
      property WindowState: TWindowState read FWindowState write FWindowState default wsNormal;
   end;

   TApp = class(TPersistent)
   private
      FPath: AnsiString;
      FCommand: AnsiString;
      FDescription: AnsiString;
      FWindowState: TWindowState;
   published
      property Description: AnsiString read FDescription write FDescription;
      property Command: AnsiString read FCommand write FCommand;
      property Path: AnsiString read FPath write FPath;
      property WindowState: TWindowState read FWindowState write FWindowState default wsNormal;
   end;

   TLaunch = class(TPersistent)
   private
      FMail: TMail;
      FApp: TApp;
      FHttp: THttp;
      FLaunchSettings: TLaunchSettings;
      procedure SetLaunchOptions(Value: TLaunchSettings);
   published
      property AsHttp: THttp read FHttp write FHttp;
      property AsMail: TMail read FMail write FMail;
      property AsApplication: TApp read FApp write FApp;
      property Options: TLaunchSettings read FLaunchSettings write SetLaunchOptions default Http;
   end;
//------------------------------------------------------------------------------
type
   TLinkLabel = class;

   TTextFlick = class(TPersistent)
   private
      FEnableFlick: Boolean;
      FlickTimer: TTimer;
      FSpeed: Integer;
      procedure SetSpeed(const Value: integer);
   published
      property Enable: Boolean read FEnableFlick write FEnableFlick default false;
      property Speed: integer read FSpeed write SetSpeed default 500;
   end;

   TTextRun = class(TPersistent)
   private
      FSteps: integer;
      FCurCycle: Integer;
      FEnableRun: Boolean;
      FDirection: TDirection;
      FSpeed: integer;
      FRepeatNumber: Word;
      FContinuous: Boolean;
      FCurrentStep: Integer;
      procedure SetDirection(Value: TDirection);
      procedure SetSteps(Value: integer);
      procedure SetSpeed(Value: Integer);
      procedure SetEnableRun(Value: Boolean);
   published
      property Enable: Boolean read FEnableRun write SetEnableRun default False;
      property Direction: TDirection read FDirection write SetDirection default diLeftToRight;
      property RepeatNumber: Word read FRepeatNumber write FRepeatNumber default 0;
      property Continuous: Boolean read FContinuous write FContinuous default True;
      property Steps: Integer read FSteps write SetSteps default 100;
      property Speed: Integer read FSpeed write SetSpeed default 100;
   end;

   TLinkLabel = class(TCustomLabel)
   private
      FAutoSize: Boolean;
      FAlignment: TAlignment;
      FLayout: TTextLayout;
      FOnLaunch: TOnLaunchEvent;
      FImageIndex: integer;
      FImageChangeLink: TChangeLink;
      FImages: TCustomImageList;
      RunTimer: TTimer;
      FTextEffects: TTextEffects;
      FLaunch: TLaunch;
      FColorOnMouseClick: Boolean;
      FHighlightOnMouseOver: Boolean;
      FTextStyle: TTextStyle;
      FTextFlick: TTextFlick;
      FTextRun: TTextRun;
      FShift: integer;
      FLinkColor: TColor;
      FDownColor: TColor;
      FUpColor: TColor;
      F3d_F_Color: TColor;
      F3d_B_Color: TColor;
      procedure SetTextStyle(Value: TTextStyle);
      procedure OnRunTimer(Sender: TObject);
      procedure CanvasTextOut(Canvas: TCanvas; X, Y: Integer; Text: string);
      procedure SetImageIndex(const Value: integer);
      procedure SetImages(Value: TCustomImageList); virtual;
      function SetWinState(State: TWindowState): Cardinal;
      procedure CMTextChanged(var Message: TMessage); message CM_TextChanged;
      procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
      procedure DoCopyAddress(Sender: TObject);
      procedure DoLaunch(Sender: TObject);
      procedure ImageListChange(Sender: TObject);
      procedure SetAlignment(Value: TAlignment);
      procedure SetLayout(Value: TTextLayout);

   protected
      function GetPopupMenu: TPopupMenu; override;
      procedure Paint; override;
      procedure Notification(AComponent: TComponent; Operation: TOperation); override;
      procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
      procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
      procedure MouseLeave(Sender: TObject);
      procedure Loaded; override;
      procedure OnFlickTimer(Sedner: Tobject);
      procedure SetAutoSize(Value: Boolean); override;
      procedure SetLinkColor(Value: TColor);
      procedure SetShift(Value: integer);
   public
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
      procedure Click; override;
      procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
      function GetProgramPathFromExt(const Ext: string): string;
   published
      property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
      property TextFlick: TTextFlick read FTextFlick write FTextFlick;
      property TextRun: TTextRun read FTextRun write FTextRun;
      property EnableColorOnClick: Boolean read FColorOnMouseClick write FColorOnMouseClick default True;
      property EnableHighlight: Boolean read FHighlightOnMouseOver write FHighlightOnMouseOver default True;
      property TextStyle: TTextStyle read FTextStyle write SetTextStyle default tsNormal;
      property ShiftShadow3D: integer read FShift write SetShift default 2;
      property Launch: TLaunch read FLaunch write FLaunch;
      property TextEffects: TTextEffects read FTextEffects write FTextEffects default teNormal;
      property Images: TCustomImageList read FImages write SetImages;
      property ImageIndex: integer read FImageIndex write SetImageIndex default -1;
      property OnLaunch: TOnLaunchEvent read FOnLaunch write FOnLaunch;
      property Alignment: TAlignment read FAlignment write SetAlignment
         default taLeftJustify;
      property Layout: TTextLayout read FLayout write SetLayout default tlBottom;
      property LinkColor: TColor read FLinkColor write SetLinkColor default clBlue;
      property DownColor: TColor read FDownColor write FDownColor default clNavy;
      property UpColor: TColor read FUpColor write FUpColor default clPurple;
      property Color_3d_F: TColor read F3d_F_Color write F3d_F_Color default clNavy;
      property Color_3d_B: TColor read F3d_B_Color write F3d_B_Color default clHighLight;
      property Align;
      property Anchors;
      property BiDiMode;
      property Caption;
      property Color nodefault;
      property Constraints;
      property Cursor default crHandPoint;
      property DragCursor;
      property DragKind;
      property DragMode;
{$IFDEF DELPHI_9_UP}
      property EllipsisPosition;
{$ENDIF}
      property Enabled;
      property FocusControl;
      property Font;
      property ParentBiDiMode;
      property ParentColor;
      property ParentFont default False;
      property ParentShowHint default False;
      property PopupMenu;
      property ShowAccelChar;
      property ShowHint default True;
      property Transparent default False;
      property Visible;
      property WordWrap default True;
      property OnClick;
      property OnContextPopup;
      property OnDblClick;
      property OnDragDrop;
      property OnDragOver;
      property OnEndDock;
      property OnEndDrag;
{$IFDEF DELPHI_9_UP}
      property OnMouseActivate;
{$ENDIF}
      property OnMouseDown;
      property OnMouseMove;
      property OnMouseUp;
{$IFDEF DELPHI_6_UP}
      property OnMouseEnter;
      property OnMouseLeave;
{$ENDIF}
      property OnStartDock;
      property OnStartDrag;
   end;

implementation
uses
   Registry, ShellAPI, Clipbrd, CommCtrl;
//Acc---------------------------------------------------------------------------

function ErrorText(ErrorCode: Integer): string;
begin
   case ErrorCode of
      0: Result := 'The operating system is out of memory or resources.';
      ERROR_FILE_NOT_FOUND: Result := 'The specified file was not found.';
      ERROR_PATH_NOT_FOUND: Result := 'The specified path was not found.';
      ERROR_BAD_FORMAT: Result := 'The .exe file is invalid (non-Microsoft Win32