Un label hyperlink (ocx)
Description
un contrôle Label,contenant un hyperlien : lorsque l'on clique dessus le navigateur s'ouvre sur le lien......
Source / Exemple :
'#######################################################################################################
' HYPERLINK CONTROL RAFF 1998
'#######################################################################################################
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Const SW_SHOWNORMAL = 1
'Déclarations d'événements:
Event HyperlinkStarted() ' click sur l'hyperlink..........
'Valeurs de propriétés par défaut:
Const m_def_VISITED = True
'Variables de propriétés:
Dim m_VISITED As Boolean
Public Function StartURL(URL As String) As Long
Dim Scr_hDC As Long
Scr_hDC = GetDesktopWindow()
StartURL = ShellExecute(Scr_hDC, "Open", URL, "", "C:\", SW_SHOWNORMAL)
RaiseEvent HyperlinkStarted ' shell lancé....
End Function
Private Sub Label1_Change()
UserControl.Height = Label1.Height + 100
UserControl.Width = Label1.Width + 200
End Sub
Private Sub Label1_Click()
StartURL (Label1.Caption)
If m_VISITED = True Then ' ici on change la couleur de bleu vers rouge (lien visité)
Label1.ForeColor = RGB(250, 0, 0)
Else
Label1.ForeColor = Label1.ForeColor
End If
End Sub
'''ATTENTION! NE PAS SUPPRIMER OU MODIFIER LES LIGNES DE COMMENTAIRES QUI SUIVENT!
'''MappingInfo=Label1,Label1,-1,AutoSize
''Public Property Get AutoSize() As Boolean
'' AutoSize = Label1.AutoSize
''End Property
''
''Public Property Let AutoSize(ByVal New_AutoSize As Boolean)
'' Label1.AutoSize() = New_AutoSize
'' PropertyChanged "AutoSize"
''End Property
'ATTENTION! NE PAS SUPPRIMER OU MODIFIER LES LIGNES DE COMMENTAIRES QUI SUIVENT!
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
UserControl.BackColor() = New_BackColor
PropertyChanged "BackColor"
End Property
'ATTENTION! NE PAS SUPPRIMER OU MODIFIER LES LIGNES DE COMMENTAIRES QUI SUIVENT!
'MappingInfo=UserControl,UserControl,-1,BorderStyle
Public Property Get BorderStyle() As Integer
BorderStyle = UserControl.BorderStyle
End Property
Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
UserControl.BorderStyle() = New_BorderStyle
PropertyChanged "BorderStyle"
End Property
'ATTENTION! NE PAS SUPPRIMER OU MODIFIER LES LIGNES DE COMMENTAIRES QUI SUIVENT!
'MappingInfo=Label1,Label1,-1,Enabled
Public Property Get Enabled() As Boolean
Enabled = Label1.Enabled
End Property
Public Property Let Enabled(ByVal New_Enabled As Boolean)
Label1.Enabled() = New_Enabled
PropertyChanged "Enabled"
End Property
'ATTENTION! NE PAS SUPPRIMER OU MODIFIER LES LIGNES DE COMMENTAIRES QUI SUIVENT!
'MappingInfo=Label1,Label1,-1,Font
Public Property Get Font() As Font
Set Font = Label1.Font
End Property
Public Property Set Font(ByVal New_Font As Font)
Set Label1.Font = New_Font
PropertyChanged "Font"
End Property
'ATTENTION! NE PAS SUPPRIMER OU MODIFIER LES LIGNES DE COMMENTAIRES QUI SUIVENT!
'MappingInfo=Label1,Label1,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
ForeColor = Label1.ForeColor
End Property
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
Label1.ForeColor() = New_ForeColor
PropertyChanged "ForeColor"
End Property
'ATTENTION! NE PAS SUPPRIMER OU MODIFIER LES LIGNES DE COMMENTAIRES QUI SUIVENT!
'MappingInfo=Label1,Label1,-1,Caption
Public Property Get URL() As String
URL = Label1.Caption
End Property
Public Property Let URL(ByVal New_URL As String)
Label1.Caption() = New_URL
PropertyChanged "URL"
End Property
'Charger les valeurs des propriétés à partir du stockage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Label1.AutoSize = PropBag.ReadProperty("AutoSize", True)
UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
Label1.Enabled = PropBag.ReadProperty("Enabled", True)
Set Font = PropBag.ReadProperty("Font", Ambient.Font)
Label1.ForeColor = PropBag.ReadProperty("ForeColor", &HFF0000)
Label1.Caption = PropBag.ReadProperty("URL", "http://www.")
m_VISITED = PropBag.ReadProperty("VISITED", m_def_VISITED)
End Sub
'Écrire les valeurs des propriétés dans le stockage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("AutoSize", Label1.AutoSize, True)
Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
Call PropBag.WriteProperty("BorderStyle", UserControl.BorderStyle, 0)
Call PropBag.WriteProperty("Enabled", Label1.Enabled, True)
Call PropBag.WriteProperty("Font", Font, Ambient.Font)
Call PropBag.WriteProperty("ForeColor", Label1.ForeColor, &HFF0000)
Call PropBag.WriteProperty("URL", Label1.Caption, "http://www.")
Call PropBag.WriteProperty("VISITED", m_VISITED, m_def_VISITED)
End Sub
Public Property Get VISITED() As Boolean
VISITED = m_VISITED
End Property
Public Property Let VISITED(ByVal New_VISITED As Boolean)
m_VISITED = New_VISITED
PropertyChanged "VISITED"
End Property
'Initialiser les propriétés pour le UserControl
Private Sub UserControl_InitProperties()
m_VISITED = m_def_VISITED
End Sub
' voir ZIP pour projet complet.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.