Bạn tạo một dự án dạng Control. Sau đó kéo một label lên trên nền control. Đặt tên là lblText. Sau đó dán các dòng code sau vào phần soạn code. Sau đó bạn biên dịch thành OCX và sử dụng trong dự án của bạn.
Option Explicit
Public Enum ActionConstants
Custom = 0
Underline = 1
Bold = 2
End Enum
Private Declare Function SetCapture Lib ''user32'' (ByVal hWnd As Long) As Long
Private Declare Function ReleaseCapture 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 mbMouseOver As Boolean
Private mbMouseDown As Boolean
Private msURL As String
Private miDefaultAction As ActionConstants
Event Click()
Event DblClick()
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event Resize()
Event OnMouseOver()
Event OnMouseOut()
Private Sub lblText_Click()
Call UserControl_Click
End Sub
Private Sub lblText_DblClick()
Call UserControl_DblClick
End Sub
Private Sub lblText_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call UserControl_MouseDown(Button, Shift, X, Y)
End Sub
Private Sub lblText_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call UserControl_MouseMove(Button, Shift, X, Y)
End Sub
Private Sub lblText_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call UserControl_MouseUp(Button, Shift, X, Y)
End Sub
Private Sub UserControl_Click()
RaiseEvent Click
End Sub
Private Sub UserControl_DblClick()
RaiseEvent DblClick
End Sub
Private Sub UserControl_InitProperties()
lblText.Caption = Extender.Name
End Sub
Sub Capture(pbValue As Boolean)
If pbValue Then
SetCapture UserControl.hWnd
Else
ReleaseCapture
End If
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseDown(Button, Shift, X, Y)
mbMouseDown = True
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseMove(Button, Shift, X, Y)
Dim lbMouseOver As Boolean
If (X < 0 Or Y < 0 Or X > UserControl.Width Or Y > UserControl.Height) Then
Capture False
mbMouseOver = False
RunDefaultAction False
RaiseEvent OnMouseOut
ElseIf mbMouseOver <> True Then
Capture True
mbMouseOver = True
RunDefaultAction True
RaiseEvent OnMouseOver
End If
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseUp(Button, Shift, X, Y)
If mbMouseOver = True Then
Capture True
RunDefaultAction True
RaiseEvent OnMouseOver
End If
If mbMouseOver = False Then
Capture False
RunDefaultAction False
RaiseEvent OnMouseOut
End If
mbMouseDown = False
GotoWeb
RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub
Private Sub UserControl_Resize()
RaiseEvent Resize
lblText.Move 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight
End Sub
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
Public Property Get Caption() As String
Caption = lblText.Caption
End Property
Public Property Let Caption(ByVal New_Caption As String)
lblText.Caption() = New_Caption
PropertyChanged ''Caption''
End Property
Public Property Get Enabled() As Boolean
Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal New_Enabled As Boolean)
UserControl.Enabled() = New_Enabled
PropertyChanged ''Enabled''
End Property
Public Property Get Font() As Font
Set Font = lblText.Font
End Property
Public Property Set Font(ByVal New_Font As Font)
Set lblText.Font = New_Font
PropertyChanged ''Font''
End Property
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
UserControl.BorderStyle = PropBag.ReadProperty(''BorderStyle'', 0)
lblText.Caption = PropBag.ReadProperty(''Caption'', Extender.Name)
UserControl.Enabled = PropBag.ReadProperty(''Enabled'', True)
Set lblText.Font = PropBag.ReadProperty(''Font'', Ambient.Font)
msURL = PropBag.ReadProperty(''URL'', '''')
miDefaultAction = PropBag.ReadProperty(''DefaultAction'', 0)
lblText.BackColor = PropBag.ReadProperty(''BackColor'', &H8000000F)
lblText.ForeColor = PropBag.ReadProperty(''ForeColor'', &H80000012)
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty(''BorderStyle'', UserControl.BorderStyle, 0)
Call PropBag.WriteProperty(''Caption'', lblText.Caption, Extender.Name)
Call PropBag.WriteProperty(''Enabled'', UserControl.Enabled, True)
Call PropBag.WriteProperty(''Font'', lblText.Font, Ambient.Font)
Call PropBag.WriteProperty(''URL'', msURL, '''')
Call PropBag.WriteProperty(''DefaultAction'', miDefaultAction, 0)
Call PropBag.WriteProperty(''BackColor'', lblText.BackColor, &H8000000F)
Call PropBag.WriteProperty(''ForeColor'', lblText.ForeColor, &H80000012)
End Sub
Public Property Get URL() As String
URL = msURL
End Property
Public Property Let URL(ByVal vNewValue As String)
msURL = vNewValue
End Property
Private Sub GotoWeb()
Dim X As Long
X = ShellExecute(0, ''Open'', msURL, '''', '''', vbNormalFocus)
End Sub
Public Property Get Action() As ActionConstants
Action = miDefaultAction
End Property
Public Property Let Action(ByVal NewAction As ActionConstants)
miDefaultAction = NewAction
End Property
Private Sub RunDefaultAction(lbValue As Boolean)
Select Case miDefaultAction
Case 1
lblText.FontUnderline = lbValue
Case 2
lblText.FontBold = lbValue
End Select
End Sub
Public Property Get BackColor() As OLE_COLOR
BackColor = lblText.BackColor
End Property
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
lblText.BackColor() = New_BackColor
PropertyChanged ''BackColor''
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor = lblText.ForeColor
End Property
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
lblText.ForeColor() = New_ForeColor
PropertyChanged ''ForeColor''
End Property