by bader (7 Submissions)
Category: Internet/HTML
Compatability: Visual Basic 4.0 (32-bit)
Difficulty: Unknown Difficulty
Originally Published: Sat 8th January 2000
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Adding Hyperlink Using the Label Control
VBcoders
'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
