ActiveX

Листинг к статье
"WithEvents – добавление новых свойств к стандартным контролам"

Класс clsNewProperty

Option Explicit

'*****************************************************************
'Объявления
'*****************************************************************
'API-функции и ее константы

Private Const SW_NORMAL = 1

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

'нумерованной константы для свойства TypeMsg

Public Enum constTypeMsg

    None = 0

    HomePage = 1

    EMail = 2

End Enum

'внутренней переменной для свойства TypeMsg

Private mvarTypeMsg As constTypeMsg

'непосредственно WithEvents

Private WithEvents NewLabel As Label

'*****************************************************************
'Добавленные свойства NewLabel
'*****************************************************************

Public Property Let TypeMsg(ByVal vData As constTypeMsg)

    mvarTypeMsg = vData

End Property

Public Property Get TypeMsg() As constTypeMsg

    TypeMsg = mvarTypeMsg

End Property

Public Property Set LabelControl(ExternalLabel As Label)

    Set NewLabel = ExternalLabel

End Property

'*****************************************************************
'Обработка событий New Label, в зависимости от выбранного свойства
'*****************************************************************

Private Sub NewLabel_Click()

    Select Case mvarTypeMsg

    Case None

    Case HomePage

        Dim X

        X = ShellExecute(0&, "Open", NewLabel.Caption, _
            &O0, &O0, SW_NORMAL)

    Case EMail

        Call ShellExecute(0&, "Open", "mailto:" + NewLabel.Caption + _
            "?Subject=" + "About WithEventsSamples", "", "", SW_NORMAL)

    End Select

End Sub

'изменение вида курсора

Private Sub NewLabel_MouseMove(Button As Integer, Shift As Integer, _
    X As Single, Y As Single)

    Select Case mvarTypeMsg

    Case None

        'NewLabel.MousePointer = vbDefault

    Case HomePage

        'можно так же использовать файл ресурсов

        NewLabel.MouseIcon = LoadPicture(App.Path & "/H_POINT.CUR")

        NewLabel.MousePointer = vbCustom

    Case EMail

        NewLabel.MouseIcon = LoadPicture(App.Path & "/H_POINT.CUR")

        NewLabel.MousePointer = vbCustom

    End Select

End Sub

Форма frmMain

Option Explicit

'*****************************************************************
'Объявление классов для каждого лейбла
'*****************************************************************

Private clsLabelHomePage As clsNewProperty

Private clsLabelEMail As clsNewProperty

'lblInfo1 и lblInfo2 не используют добавленных свойств, они
'служат только для выведения надписей. Однако здесь им специально
'присвоены новые свойства, чтобы показать, как необходимо их
'обрабатывать

Private clsLabelInfo1 As clsNewProperty

Private clsLabelInfo2 As clsNewProperty

Private Sub Form_Load()

    'инициализация класса

    Set clsLabelHomePage = New clsNewProperty

    'присвоение кконкретного класса конкретному лейблу

    Set clsLabelHomePage.LabelControl = lblHomePage

    'установка дополнительных свойств

    clsLabelHomePage.TypeMsg = HomePage

    'идентично для других лейблов

    Set clsLabelEMail = New clsNewProperty

    Set clsLabelEMail.LabelControl = lblEMail

    clsLabelEMail.TypeMsg = EMail

    Set clsLabelInfo1 = New clsNewProperty

    Set clsLabelInfo1.LabelControl = lblInfo1

    clsLabelInfo1.TypeMsg = None

    Set clsLabelInfo2 = New clsNewProperty

    Set clsLabelInfo2.LabelControl = lblInfo2

    clsLabelInfo2.TypeMsg = None

End Sub

К статье