• Home
 · 
• Internet/HTML
 · 
• Adding Hyperlink Using the Label Control

Adding Hyperlink Using the Label Control

Adding Hyperlink Using the Label Control

Rate Adding Hyperlink Using the Label Control

• 1
• 2
• 3
• 4
• 5

(2(2 Vote))

'then add the following:

Option Explicit


Private Const clrLinkActive = vbBlue
Private Const clrLinkHot = vbRed
Private Const clrLinkInactive = vbBlack

Private Const SW_SHOWNORMAL As Long = 1
Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const SW_SHOWDEFAULT As Long = 10

Private Type POINTAPI
   X As Long
   Y As Long
End Type

Private Declare Function GetCursorPos Lib "user32" _
  (lpPoint As POINTAPI) As Long

Private Declare Function ScreenToClient Lib "user32" _
  (ByVal hwnd As Long, _
   lpPoint As POINTAPI) As Long

Private Declare Function GetDesktopWindow Lib "user32" () As Long

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 Sub Form_Load()

Text1.Text = "http://www.vbcode.com/asp/code.asp"
Label1.AutoSize = True
      
End Sub


Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
With Label1
.ForeColor = clrLinkInactive
.FontUnderline = False
End With
End Sub

Private Sub label1_Click()

   Dim sURL As String

  'open the URL using the default browser
   sURL = Label1.Caption

   Call RunShellExecute("open", sURL, 0&, 0&, SW_SHOWNORMAL)
   
End Sub


Private Sub RunShellExecute(sTopic As String, sFile As Variant, _
                           sParams As Variant, sDirectory As Variant, _
                           nShowCmd As Long)

  'execute the passed operation, passing
  'the desktop as the window to receive
  'any error messages
   Call ShellExecute(GetDesktopWindow(), _
                     sTopic, _
                     sFile, _
                     sParams, _
                     sDirectory, _
                     nShowCmd)

End Sub


Private Sub Text1_Change()

  'reflect changes to the textbox
   Label1.Caption = Text1.Text

End Sub


Private Sub Text1_GotFocus()

   Dim pos As String
   
  'if the textbox has the URL double
  'slashes, select only the text after
  'them for editing convenience
   pos = InStr(Text1.Text, "//")
   
   If pos Then
   
      With Text1
         .SelStart = pos + 1
         .SelLength = Len(.Text)
      End With
      
   End If


End Sub


Private Sub label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
   With Label1
   
         .ForeColor = clrLinkActive
         .FontUnderline = True
   
   End With
   
End Sub