Accueil > Manip’s > Delphi > Composants / Librairies > Installer un Paquet de composants tout faits > jcUrLabel (code)
jcUrLabel (code)

mardi 24 juin 2008, par bluegyn_spip
unit jcUrLabel;







interface







uses



  Windows, Messages, SysUtils, Classes, Controls, StdCtrls,



  Graphics {clBlue}, ShellApi{ShellExecute}, Registry { Openkey };







type



  TjcUrLabel = class(TCustomLabel) // class(tlabel)







  private



    { Déclarations privées }



    FURL:string; // On rajoute le champ URL a l'étiquette



    Fauteur : string ;







    FOld_FontColor, FOld_BackColor: TColor;



                FHover_FontColor, FHover_BackColor : Tcolor;



    FOld_Style, FHover_Style :  TFontStyles;







    FOnMouseEnter, FOnMouseLeave: TNotifyEvent;







    procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;



    procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;







  protected



    { Déclarations protégées }



    procedure Click; override; // rédéfinition du Clic -> Ouvre URL







  public



    { Déclarations publiques }



    Constructor Create (Aowner : Tcomponent) ; override ;



                Destructor Destroy ; override ;







                function getNavigator () : string;







  published



    { Déclarations publiées }







        



    // Propriété rajoutées au Controle de base



    property URL:string read FURL write FURL nodefault;



    property HoverBGColor : TColor read FHover_BackColor write FHover_BackColor;



    property HoverColor : TColor read FHover_FontColor write FHover_FontColor;



    property HoverStyle :  TFontStyles read FHover_Style write FHover_Style;







    property Auteur :  string read Fauteur;



    



  { Autres Propriétés standards disponibles }



    property Align;



    property Alignment;



    property Anchors;



    property AutoSize;



//    property BiDiMode;



    property Caption;



    property Color;



    property Constraints;



    property Cursor;



//    property DragCursor;



//    property DragKind;



//    property DragMode;



    property Enabled;



    property FocusControl;



    property Font;



    property Hint;







//    property Layout;



//    property ParentBiDiMode;



    property ParentShowHint;



    property PopupMenu;



//    property ShowAccelChar;



    property ShowHint;



    property Transparent;



    property Visible;



//    property WordWrap;







  { Evenements standards d'un TLABEL }







    property OnClick;



    property OnDblClick;



//    property OnDragDrop;



//    property OnDragOver;



//    property OnEndDock;



//    property OnEndDrag;



//    property OnMouseDown;



    property OnMouseMove;



//    property OnMouseUp;



//    property OnStartDock;



//    property OnStartDrag;



//        property OnMouseEnter;



//  property OnMouseLeave;







  end;







procedure Register;







implementation







////////////////////////////////////////////////////////////////////////////////



Constructor TjcUrLabel.Create( AOwner : Tcomponent) ;



Begin



inherited Create(Aowner);







// valeurs par défaut



HoverBGColor := clSkyBlue;



HoverColor := clBlue;



HoverStyle := [fsUnderline, fsBold];



Url := 'http://bluegyn.com';







Cursor := crHandPoint;



Caption := 'Visitez le petit journal';







End ;







////////////////////////////////////////////////////////////////////////////////



Destructor TjcUrLabel.Destroy ;



Begin



inherited Destroy ;



End ;







////////////////////////////////////////////////////////////////////////////////



procedure TjcUrLabel.Click;



var



        SI : TStartupInfo;



  PI : TProcessInformation;



  Commande : string;







Begin







inherited;



if Furl = '' then Furl := caption;



if hint = '' then hint := furl;







FillChar(SI, SizeOf(SI), 0);







Commande := getNavigator() + ' ' + FURL;







CreateProcess(nil, Pchar(commande) ,nil,nil,true,0,nil,nil,SI,PI);







// ShellExecute(0,'OPEN', pChar(FURL), nil, nil, SW_SHOW);







End;















////////////////////////////////////////////////////////////////////////////////



procedure TjcUrLabel.CMMouseEnter(var Msg: TMessage);



begin



  if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);







  FOld_FontColor := Font.Color;



  Fold_BackColor := Color;



  Fold_style := Font.Style;







  Font.Color := Fhover_FontColor;;











  Color := FHover_BackColor;







        font.Style := [fsUnderline, fsbold];







  Refresh;



end;







////////////////////////////////////////////////////////////////////////////////



procedure TjcUrLabel.CMMouseLeave(var Msg: TMessage);



begin



  if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);







  font.Color := FOld_FontColor;



  Color := FOld_BackColor;







        font.Style := Fold_style;







  Refresh;



end;







////////////////////////////////////////////////////////////////////////////////



procedure Register;



begin



  RegisterComponents('Plumes', [TjcUrLabel]);



end;







////////////////////////////////////////////////////////////////////////////////



function TjcUrLabel.getNavigator()  : string;



Var



  Registre : TRegistry;



  Navigator : string;



begin



  //Crée un objet TRegistry



  Registre:=TRegistry.Create;







  //Définit la clé principale



  Registre.RootKey:=Hkey_classes_root;







  //Ouvre la clé du navigateur



  Registre.OpenKey('\http\shell\open\command', false); // n'est pas crée si existe pas







  if Registre.ValueExists('') then



          begin



    Navigator := trim(Registre.ReadString(''));



    navigator := copy ( navigator, 1, pos(' ', navigator) );



    Result := Navigator;



          end



  else result := '';







  //Ferme la clé



  Registre.CloseKey;







  //Détruit l'objet



  Registre.Free;







End;







end.
jcUrLabel (code)

Manip’s

Dans la même rubrique
