Sección de código fuente Visual basic

Módulo de clase para crear HiperVínculos en Visual basic

El siguente código fuente es un módulo de clase que permite crear Hipervínculos por medio de un control PictureBox.

En el módulo, están definidas las propiedades principales

Texto : texto que se imprimirá en el control, es decir el texto del Hipervinculo
Url: Dirección Http para abrir al pulsar el enlace con el navegador predeterminado
TextColorNormal: Color del texto en estado normal
TextColorUp: Color del texto al pasar el mouse por encima

TextColorDown: Color del texto al pulsar el enlace

Antes de establecerle las propiedades, hay que iniciar la clase, pasandole al método Iniciar, como parámentro, el control PictureBox y el formulario, por ejemplo

Call Clase.Iniciar (Picture1, Me)

Importante: Como el módulo utiliza Withevents para el PictureBox dentro de la clase, no se puede utilizar con arreglos o matrices de PictureBox, es decir esto no es válido:

Call Clase.Iniciar (Picture (1), Me)

En conlusión, solo se permite utilizar Picturebox que no formen una matriz

Para detectar el MouseOut en el control se utiliza el Api PtlnRect en conjunto con RelaseCapture, SendMessage y GetCursorPos

Otra cosa, es que, yo para no complicarmela demasiado, el módulo al iniciar, crea un control Label en tiempo de ejecución con el método Add de la colección Forms, esto es para asignar el texto al label y luego asignar el mismo al Picture, para que no haya problemas con el tema del tamaño de las fuentes y demás, aunque esto se puede quitar y utilizar algunas Apis que rescaten las dimensiones de la fuente.

Por último: Para establecerle el cursor de Hipervinculo o un puntero personalizado para los enlaces web, hay que establecerlo de la siguiente forma, por ejemplo:

LaClase.MousePointer = VbCustom

LaClase.MouseIcon = LoadPicture ( Ruta del ícono a utilizar)

.. el archivo de cursor que es una mano, se llama h_Point.Cur y está situado en la carpeta de instalación de Visual basic, en mi caso en la siguiente ruta:

C:\Archivos de programa\Microsoft Visual Studio\Common\Graphics\Cursors\H_POINT.Cur

A continuación sigue el Código fuente del módulo de clase y al final está el código que hay que pegar en el formulario para el ejemplo.

Código del módulo de clase y un ejemplo para usarlo

Añadir el siguiente código en un Módulo de clase por defecto dejarlo con el nombre Class1

Option Explicit 'Declaración de funciones Api '**************************************************** 'GetCursorPos - obtener las cordenadas del mouse Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINT_API) As Long 'SetCapture para capturar una ventana Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long 'Para liberarla Private Declare Function ReleaseCapture Lib "user32" () As Long 'PtInRect - determinar si el mouse está en la región del Picture Private Declare Function PtInRect Lib "user32" ( _ lpRect As RECT, _ ByVal X As Long, _ ByVal Y As Long) As Long 'GetWindowRect Para recuperar el area de la ventana Private Declare Function GetWindowRect Lib "user32" ( _ ByVal hWnd As Long, _ lpRect As RECT) As Long 'ShellExecute Para navegar a la url al hacer click en el Picture 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 'Para utilizar con el api GetCursorPos Private Type POINT_API X As Long Y As Long End Type 'UDT RECT Para utilizar con PtInRect y con GetWindowRect Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type 'Flag para el evento los eventos del mous cuando está arriba y abajo Private Enum Flag Arriba = 0 Presionado = 1 End Enum 'Para el Enum flag anterior Dim Estado As Flag 'Variables locales Private m_ColorTextNormal As Long Private m_ColorTextUp As Long Private m_ColorTextDown As Long Private m_BorderStyle As Boolean Private m_Url As String Private unLabel As Label Private m_Texto As String Private m_Init As Boolean Private WithEvents m_Picture As PictureBox 'Comprueba el área del mouse si está dentro o fuera del Picture. 'Si está fuera devueve False Private Function ComprobarArea(X As Single, Y As Single) As Boolean Dim pnt As POINT_API, rBox As RECT 'Recuperamos área del Picture box y la guardamos en rBox GetWindowRect m_Picture.hWnd, rBox 'Recuperamos las coordenadas del mouse GetCursorPos pnt 'Verificamos si está en el área If PtInRect(rBox, pnt.X, pnt.Y) Then ComprobarArea = True Else ComprobarArea = False End If End Function Private Sub Class_Terminate() On Local Error Resume Next Set m_Picture = Nothing Set unLabel = Nothing End Sub Private Sub m_Picture_MouseDown(Button As Integer, Shift As Integer, _ X As Single, Y As Single) Estado = Presionado m_Picture.ForeColor = m_ColorTextDown Call Dibujar End Sub Private Sub m_Picture_Click() 'Navegamos a la Url pasandole a ShellExecute la dirección Call ShellExecute(hWnd, "open", m_Url, _ vbNullString, vbNullString, 1) End Sub Private Sub m_Picture_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) SetCapture m_Picture.hWnd 'Le enviamos los valores del mouse a la función que comprueba _ si está en el área del Picture If ComprobarArea(X, Y) Then If Button = vbLeftButton Then Estado = Presionado Else Estado = Arriba End If If Estado = Arriba Then m_Picture.ForeColor = m_ColorTextUp Call Dibujar End If Else 'Si se ejecuta estas instrucciones es por que el _ mouse salió del área del Picture m_Picture.ForeColor = m_ColorTextNormal Call Dibujar 'Liberamos ReleaseCapture End If End Sub Private Sub m_Picture_MouseUp(Button As Integer, Shift As Integer, _ X As Single, Y As Single) ReleaseCapture Estado = Arriba 'cambiamos el color de la fuente m_Picture.ForeColor = m_ColorTextUp Call Dibujar End Sub Private Sub Dibujar() 'Borramos el texto del Picture m_Picture.Cls 'Dibujamos el texto m_Picture.Print unLabel.Caption End Sub Sub Iniciar(UnPictureBox As PictureBox, ElForm As Form) Static i As Integer i = ElForm.Controls.Count 'Referenciamos la variable de tipo Picture al Control enviado como parámetro Set m_Picture = UnPictureBox 'Creamos un Label en tiempo de ejecución If Not m_Init Then Set unLabel = ElForm.Controls.Add("VB.Label", "UnLabel" & CStr(i)) Else Exit Sub End If With m_Picture .CurrentX = 0 .CurrentY = 0 .AutoRedraw = True .ScaleMode = 1 .ForeColor = m_ColorTextNormal End With unLabel.AutoSize = True 'm_Picture.Print Texto Estado = Arriba Call Resize m_Init = True End Sub 'cada ves que cambia alguna propiedad redimencionamos el control Picture 'para que sea igual al tamaño del label y también dibuja el texto Private Sub Resize() m_Picture.Width = unLabel.Width + 80 m_Picture.Height = unLabel.Height + 40 Call Dibujar End Sub 'Propiedades '####################################### Property Get ColorTextNormal() As Long ColorTextNormal = m_ColorTextNormal End Property Property Let ColorTextNormal(NewColor As Long) m_ColorTextNormal = NewColor m_Picture.ForeColor = NewColor Call Dibujar End Property Property Get ColorTextUp() As Long ColorTextUp = m_ColorTextUp End Property Property Let ColorTextUp(NewColor As Long) m_ColorTextUp = NewColor End Property Property Get ColorTextDown() As Long ColorTextDown = m_ColorTextDown End Property Property Let ColorTextDown(NewColor As Long) m_ColorTextDown = NewColor End Property Property Get Texto() As String Texto = unLabel.Caption End Property Property Let Texto(NewTexto As String) unLabel.Caption = NewTexto Resize End Property Property Get FontSize() As Single FontSize = unLabel.FontSize End Property Property Let FontSize(NewSize As Single) unLabel.FontSize = NewSize m_Picture.FontSize = NewSize Resize End Property Property Get FontName() As String FontSize = unLabel.FontName End Property Property Let FontName(NewFont As String) unLabel.FontName = NewFont m_Picture.FontName = NewFont Resize End Property Property Get FontBold() As Boolean FontBold = unLabel.FontBold End Property Property Let FontBold(valor As Boolean) unLabel.FontBold = valor m_Picture.FontBold = valor Resize End Property Property Get FontItalic() As Boolean FontItalic = unLabel.FontItalic End Property Property Let FontItalic(valor As Boolean) unLabel.FontItalic = valor m_Picture.FontItalic = valor Resize End Property Property Get FontStrikethru() As Boolean FontStrikethru = unLabel.FontStrikethru End Property Property Let FontStrikethru(valor As Boolean) unLabel.FontStrikethru = valor m_Picture.FontStrikethru = valor Resize End Property Property Get FontUnderline() As Boolean FontUnderline = unLabel.FontUnderline End Property Property Let FontUnderline(valor As Boolean) unLabel.FontUnderline = valor m_Picture.FontUnderline = valor Resize End Property Property Get Borde() As Boolean Borde = m_Picture.BorderStyle End Property Property Let Borde(v As Boolean) If v Then m_Picture.BorderStyle = 1 Else m_Picture.BorderStyle = 0 End If Resize End Property Property Get MousePointer() As MousePointerConstants MousePointer = m_Picture.MousePointer End Property Property Let MousePointer(valor As MousePointerConstants) m_Picture.MousePointer = valor End Property Property Get MouseIcon() As Picture MouseIcon = m_Picture.MouseIcon End Property Property Let MouseIcon(valor As Picture) m_Picture.MouseIcon = valor End Property Property Set MouseIcon(valor As Picture) Set m_Picture.MouseIcon = valor End Property Property Get Url() As String Url = m_Url End Property Property Let Url(New_Url As String) m_Url = New_Url m_Picture.ToolTipText = New_Url End Property

Pegar el siguiente Código en un formulario y agregar 3 controles Picture, Picture1, Picture2 y Picture3

Option Explicit 'Variables para la clase Dim Link1 As Class1 Dim Link2 As Class1 Dim Link3 As Class1 Private Sub Form_Load() 'Creamos una nueva instancia de la clase para cada _ picture que tendrá el Hipervinculo Set Link1 = New Class1 Set Link2 = New Class1 Set Link3 = New Class1 'Crea el Hipervinculo 1 With Link1 .Iniciar Picture1, Me .FontSize = 20 .FontUnderline = True .ColorTextNormal = &HFF00FF .ColorTextDown = vbWhite .ColorTextUp = vbBlue .FontName = "verdana" .Url = "http://www.google.com.ar" .Texto = " Página de Google " .Borde = False 'Especificar el puntero del Mouse ''''''''''''''''''''''''''''''''''''' '.MousePointer = vbCustom '.MouseIcon = LoadPicture(Ruta del icono) End With 'Hipervinculo 2 With Link2 .Iniciar Picture2, Me .FontSize = 18 .FontItalic = True .ColorTextNormal = &H40C0& .ColorTextUp = vbYellow .ColorTextDown = vbYellow .FontName = "Arial" .Url = "http://www.yahoo.com.ar" .Texto = " Página de yahoo " .Borde = False End With 'Hipervinculo 3 With Link3 .Iniciar Picture3, Me .FontSize = 16 .ColorTextNormal = &HC00000 .ColorTextUp = vbGreen .ColorTextDown = vbGreen .FontName = "Arial" .Url = "http://www.microsoft.com" .Texto = " Página de Microsoft " .Borde = False End With End Sub Private Sub Form_Unload(Cancel As Integer) 'Eliminamos las referencias Set Link1 = Nothing Set Link2 = Nothing Set Link3 = Nothing End Sub

Enlaces relacionados

Crear un hipervínculo en visual basic mediante el api ShellExecute

Buscar en Recursos vb