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 1000
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
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
|
|
