Листинг для Урока 6
ActiveX Control "ControlPanel"
'*****************************************************************
'Урок
6
'ActiveX Control - "ControlPanel"
'Листинг
'*****************************************************************
Option Explicit
'*****************************************************************
'Объявление нумерованных констант
'*****************************************************************
Public Enum constVStyle
Выпуклый = 0
Вдавленный = 1
End Enum
Public Enum constOrientation
Горизонтальный = 0
Вертикальный = 1
End Enum
Public Enum constBackColor
Красно_Черный = 0
Желто_Черный = 1
Серо_Черный = 2
Зелено_Черный = 3
Бирюзово_Черный = 4
Cине_Черный = 5
Желто_Зеленый = 6
Розово_Синий = 7
Бело_Бирюзовый = 8
Бело_Голубой = 9
Бирюзово_Синий = 10
Желто_Красный = 11
Бело_Сиреневый = 12
Бело_Красный = 13
Сине_Зеленый = 14
Сиренево_Красный = 15
Бело_Желтый = 16
End Enum
'*****************************************************************
'Объявление констант
'*****************************************************************
Const m_def_Gradient = False
Const m_def_Caption = "Panel"
Const m_def_BorderStyle = 0
Const m_def_GradientColor = 0
Const m_def_GradientOrientation = 0
Const m_def_FontStyle = 0
Const m_def_ForeColor = &H80000012
'*****************************************************************
'Цвета теней для создания объема
'*****************************************************************
Const GREY = &H8000000C
Const WHITE = &HFFFFFF
'*****************************************************************
'Объявление внутренних переменных
'*****************************************************************
Dim m_Gradient As Boolean
Dim m_Caption As String
Dim m_BorderStyle As constVStyle
Dim m_GradientColor As constBackColor
Dim m_GradientOrientation As constOrientation
Dim m_FontStyle As constVStyle
Dim m_ForeColor As OLE_COLOR
'*****************************************************************
'Объявление событий
'*****************************************************************
Event Click()
Event DblClick()
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseDown(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)
'*****************************************************************
'Свойства контрола
'*****************************************************************
Public Property Get BorderStyle() As constVStyle
BorderStyle = m_BorderStyle
End Property
Public Property Let BorderStyle(ByVal New_BorderStyle As constVStyle)
m_BorderStyle = New_BorderStyle
DrawControl
PropertyChanged "BorderStyle"
End Property
Public Property Get FontStyle() As constVStyle
FontStyle = m_FontStyle
End Property
Public Property Let FontStyle(ByVal New_FontStyle As constVStyle)
m_FontStyle = New_FontStyle
DrawControl
PropertyChanged "FontStyle"
End Property
Public Property Get Gradient() As Boolean
Gradient = m_Gradient
End Property
Public Property Let Gradient(ByVal New_Gradient As Boolean)
m_Gradient = New_Gradient
DrawControl
PropertyChanged "Gradient"
End Property
Public Property Get GradientColor() As constBackColor
GradientColor = m_GradientColor
End Property
Public Property Let GradientColor(ByVal New_GradientColor As constBackColor)
m_GradientColor = New_GradientColor
DrawControl
PropertyChanged "GradientColor"
End Property
Public Property Get GradientOrientation() As constOrientation
GradientOrientation = m_GradientOrientation
End Property
Public Property Let GradientOrientation(ByVal New_GradientOrientation As constOrientation)
m_GradientOrientation = New_GradientOrientation
DrawControl
PropertyChanged "GradientOrientation"
End Property
Public Property Get Caption() As String
Caption = m_Caption
End Property
Public Property Let Caption(ByVal New_Caption As String)
m_Caption = New_Caption
DrawControl
PropertyChanged "Caption"
End Property
Public Property Get Font() As Font
Set Font = UserControl.Font
End Property
Public Property Set Font(ByVal New_Font As Font)
Set UserControl.Font = New_Font
DrawControl
PropertyChanged "Font"
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor = m_ForeColor
End Property
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
m_ForeColor = New_ForeColor
DrawControl
PropertyChanged "ForeColor"
End Property
Public Property Get BackColor() As OLE_COLOR
BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
UserControl.BackColor() = New_BackColor
DrawControl
PropertyChanged "BackColor"
End Property
'*****************************************************************
'Внутренние процедуры
'*****************************************************************
Private Sub DrawControl()
Dim R%, G%, B%
Dim i%, NbrRects%, GradValue%, GradColor&
UserControl.Cls
If m_Gradient = True Then
NbrRects% = 128
For i = 1 To NbrRects
GradValue = 255 - (i * 2 - 1)
Select Case m_GradientColor
Case 0
R = GradValue
G = 0
B = 0
Case 1
R = GradValue
G = GradValue
B = 0
Case 2
R = GradValue
G = GradValue
B = GradValue
Case 3
R = 0
G = GradValue
B = 0
Case 4
R = 0
G = GradValue
B = GradValue
Case 5
R = 0
G = 0
B = GradValue
Case 6
R = GradValue
G = 255
B = 0
Case 7
R = GradValue
G = 0
B = 255
Case 8
R = GradValue
G = 255
B = 255
Case 9
R = GradValue
G = GradValue
B = 255
Case 10
R = 0
G = GradValue
B = 255
Case 11
R = 255
G = GradValue
B = 0
Case 12
R = 255
G = GradValue
B = 255
Case 13
R = 255
G = GradValue
B = GradValue
Case 14
R = 0
G = 255
B = GradValue
Case 15
R = 255
G = 0
B = GradValue
Case 16
R = 255
G = 255
B = GradValue
Case Else 'если по ошибке поставят < 0 или > 16
R = 0
G = 0
B = GradValue
End Select
GradColor = RGB(R, G, B)
Select Case m_GradientOrientation
Case 0
Line (0, ScaleHeight * (i - 1) / NbrRects)-(ScaleWidth, ScaleHeight * i / NbrRects), GradColor&, BF
Case 1
Line (ScaleWidth * (i - 1) / NbrRects, 0)-(ScaleWidth * i / NbrRects, ScaleHeight), GradColor&, BF
Case Else 'если по ошибке поставят < 0 или > 1
Line (0, ScaleHeight * (i - 1) / NbrRects)-(ScaleWidth, ScaleHeight * i / NbrRects), GradColor&, BF
End Select
Next i
End If
CurrentX = (ScaleWidth - TextWidth(m_Caption)) / 2 - 0.5
CurrentY = (ScaleHeight - TextHeight(m_Caption)) / 2 - 0.5
If m_FontStyle = Выпуклый Then
UserControl.ForeColor = WHITE
Else
UserControl.ForeColor = GREY
End If
UserControl.Print m_Caption
CurrentX = (ScaleWidth - TextWidth(m_Caption)) / 2 + 1
CurrentY = (ScaleHeight - TextHeight(m_Caption)) / 2 + 1
If m_FontStyle = Выпуклый Then
UserControl.ForeColor = GREY
Else
UserControl.ForeColor = WHITE
End If
UserControl.Print m_Caption
CurrentX = (ScaleWidth - TextWidth(m_Caption)) / 2
CurrentY = (ScaleHeight - TextHeight(m_Caption)) / 2
UserControl.ForeColor = m_ForeColor
UserControl.Print m_Caption
Select Case m_BorderStyle
Case Вдавленный
Line (0, 0)-(0, ScaleHeight - 1), GREY
Line -(ScaleWidth - 1, ScaleHeight - 1), WHITE
Line -(ScaleWidth - 1, 0), WHITE
Line -(0, 0), GREY
Case Выпуклый
Line (0, 0)-(0, ScaleHeight - 1), WHITE
Line -(ScaleWidth - 1, ScaleHeight - 1), GREY
Line -(ScaleWidth - 1, 0), GREY
Line -(0, 0), WHITE
End Select
End Sub
'*****************************************************************
'Обработка событий UserControl и контрола Panel
'*****************************************************************
Private Sub UserControl_InitProperties()
m_BorderStyle = m_def_BorderStyle
m_GradientColor = m_def_GradientColor
m_GradientOrientation = m_def_GradientOrientation
Set UserControl.Font = Ambient.Font
m_Gradient = m_def_Gradient
m_Caption = m_def_Caption
m_FontStyle = m_def_FontStyle
m_ForeColor = m_def_ForeColor
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_BorderStyle = PropBag.ReadProperty("BorderStyle", m_def_BorderStyle)
m_GradientColor = PropBag.ReadProperty("GradientColor", m_def_GradientColor)
m_GradientOrientation = PropBag.ReadProperty("GradientOrientation", m_def_GradientOrientation)
Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
m_ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
m_Gradient = PropBag.ReadProperty("Gradient", m_def_Gradient)
m_Caption = PropBag.ReadProperty("Caption", m_def_Caption)
m_FontStyle = PropBag.ReadProperty("FontStyle", m_def_FontStyle)
End Sub
Private Sub UserControl_Resize()
DrawControl
End Sub
Private Sub UserControl_Show()
DrawControl
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, m_def_BorderStyle)
Call PropBag.WriteProperty("GradientColor", m_GradientColor, m_def_GradientColor)
Call PropBag.WriteProperty("GradientOrientation", m_GradientOrientation, m_def_GradientOrientation)
Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
Call PropBag.WriteProperty("ForeColor", m_ForeColor, &H80000012)
Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
Call PropBag.WriteProperty("Gradient", m_Gradient, m_def_Gradient)
Call PropBag.WriteProperty("Caption", m_Caption, m_def_Caption)
Call PropBag.WriteProperty("FontStyle", m_FontStyle, m_def_FontStyle)
End Sub
Private Sub UserControl_Click()
RaiseEvent Click
End Sub
Private Sub UserControl_DblClick()
RaiseEvent DblClick
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub
Public Sub About()
frmAbout.Show vbModal
End Sub
Option Explicit
Private bSelected As Boolean
Private Sub cboBorderStyle_Click()
If Not bSelected Then Changed = True
End Sub
Private Sub cboFontStyle_Click()
If Not bSelected Then Changed = True
End Sub
Private Sub cboGradientColor_Click()
If Not bSelected Then Changed = True
End Sub
Private Sub cboGradientOrientation_Click()
If Not bSelected Then Changed = True
End Sub
Private Sub txtCaption_Change()
If Not bSelected Then Changed = True
End Sub
Private Sub chkGradient_Click()
If Not bSelected Then Changed = True
End Sub
Private Sub PropertyPage_ApplyChanges()
SelectedControls(0).Caption = txtCaption.Text
SelectedControls(0).Gradient = (chkGradient.Value = vbChecked)
SelectedControls(0).GradientOrientation = cboGradientOrientation.ListIndex
SelectedControls(0).GradientColor = cboGradientColor.ListIndex
SelectedControls(0).BorderStyle = cboBorderStyle.ListIndex
SelectedControls(0).FontStyle = cboFontStyle.ListIndex
End Sub
Private Sub PropertyPage_SelectionChanged()
bSelected = True
cboGradientOrientation.Clear
cboGradientOrientation.AddItem "0 - Горизонтальный"
cboGradientOrientation.AddItem "1 - Вертикальный"
cboGradientColor.Clear
cboGradientColor.AddItem "0 - Красно_Черный"
cboGradientColor.AddItem "1 - Желто_Черный"
cboGradientColor.AddItem "2 - Серо_Черный"
cboGradientColor.AddItem "3 - Зелено_Черный"
cboGradientColor.AddItem "4 - Бирюзово_Черный"
cboGradientColor.AddItem "5 - Cине_Черный"
cboGradientColor.AddItem "6 - Желто_Зеленый"
cboGradientColor.AddItem "7 - Розово_Синий"
cboGradientColor.AddItem "8 - Бело_Бирюзовый"
cboGradientColor.AddItem "9 - Бело_Голубой"
cboGradientColor.AddItem "10 - Бирюзово_Синий"
cboGradientColor.AddItem "11 - Желто_Красный"
cboGradientColor.AddItem "12 - Бело_Сиреневый"
cboGradientColor.AddItem "13 - Бело_Красный"
cboGradientColor.AddItem "14 - Сине_Зеленый"
cboGradientColor.AddItem "15 - Сиренево_Красный"
cboGradientColor.AddItem "16 - Бело_Желтый"
cboBorderStyle.Clear
cboBorderStyle.AddItem "0 - Выпуклый"
cboBorderStyle.AddItem "1 - Вдавленный"
cboFontStyle.Clear
cboFontStyle.AddItem "0 - Выпуклый"
cboFontStyle.AddItem "1 - Вдавленный"
txtCaption.Text = SelectedControls(0).Caption
chkGradient.Value = (SelectedControls(0).Gradient And vbChecked)
cboGradientOrientation.ListIndex = SelectedControls(0).GradientOrientation
cboGradientColor.ListIndex = SelectedControls(0).GradientColor
cboBorderStyle.ListIndex = SelectedControls(0).BorderStyle
cboFontStyle.ListIndex = SelectedControls(0).FontStyle
bSelected = False
End Sub