Листинг для Урока 4
ActiveX Control "pbHrglss"
Option Explicit
'*****************************************************************
'Объявление API-функций
'*****************************************************************
Private Declare Function SetWindowRgn Lib "user32" _
(ByVal hWnd As Long, _
ByVal hRgn As Long, _
ByVal bRedraw As Boolean) _
As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint
As POINTAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long) _
As Long
'*****************************************************************
'Объявление констант API-функций
'*****************************************************************
'Private Const ALTERNATE = 1
Private Const WINDING = 2
'*****************************************************************
'Объявление типа для API-функций
'*****************************************************************
Private Type POINTAPI
X As Long
Y As Long
End Type
'*****************************************************************
'Объявление массива, для сохранения
координат
'*****************************************************************
Private rgnPts() As POINTAPI
'*****************************************************************
'Объявление значений по умолчанию
для свойств
'*****************************************************************
Const m_def_Percent = vbNullString
Const m_def_BasisColor = &HFF0000
Const m_def_SandColor = &H80FF&
Const m_def_Min = 0
Const m_def_Max = 100
Const m_def_Value = 0
'*****************************************************************
'Внутренние переменные для свойств
'*****************************************************************
Dim m_Percent As String
Dim m_BasisColor As OLE_COLOR
Dim m_SandColor As OLE_COLOR
Dim m_Min As Long
Dim m_Max As Long
Dim m_Value As Long
'*****************************************************************
'Свойства
'*****************************************************************
Public Property Get Value() As Long
Value = m_Value
End Property
Public Property Let Value(ByVal New_Value As Long)
m_Value = New_Value
PropertyChanged "Value"
DrawControl
End Property
Public Property Get Min() As Long
Min = m_Min
End Property
Public Property Let Min(ByVal New_Min As Long)
m_Min = New_Min
PropertyChanged "Min"
DrawControl
End Property
Public Property Get Max() As Long
Max = m_Max
End Property
Public Property Let Max(ByVal New_Max As Long)
m_Max = New_Max
PropertyChanged "Max"
DrawControl
End Property
Public Property Get Percent() As String
Percent = Format((m_Value - m_Min) * 100 / _
(m_Max - m_Min), "0") & "%"
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
PropertyChanged "BackColor"
DrawControl
End Property
Public Property Get BasisColor() As OLE_COLOR
BasisColor = m_BasisColor
End Property
Public Property Let BasisColor(ByVal New_BasisColor As OLE_COLOR)
m_BasisColor = New_BasisColor
PropertyChanged "BasisColor"
DrawControl
End Property
Public Property Get SandColor() As OLE_COLOR
SandColor = m_SandColor
End Property
Public Property Let SandColor(ByVal New_SandColor As OLE_COLOR)
m_SandColor = New_SandColor
PropertyChanged "SandColor"
DrawControl
End Property
'*****************************************************************
'Метод
'*****************************************************************
Public Sub About()
frmAbout.Show vbModal
End Sub
'*****************************************************************
'Внутренняя процедура
'*****************************************************************
Private Sub DrawControl()
Cls
ScaleMode = 3
DrawWidth = 2
DrawStyle = 6
AutoRedraw = True
If m_Value <> m_Max Then
Line (0, (m_Value - m_Min) * ScaleHeight * 0.5 / _
(m_Max - m_Min))-(ScaleWidth, ScaleHeight * 0.5), _
m_SandColor, BF
Line (ScaleWidth * 0.45, ScaleHeight * 0.5)- _
(ScaleWidth * 0.54, ScaleHeight * 0.95), m_SandColor, BF
Line (0, ScaleHeight - ((m_Value - m_Min) * ScaleHeight * 0.5 / _
(m_Max - m_Min)))-(ScaleWidth, ScaleHeight * 0.95), _
m_SandColor, BF
End If
Line (0, 0)-(ScaleWidth, ScaleHeight * 0.05), m_BasisColor, BF
Line (0, ScaleHeight * 0.95)-(ScaleWidth, ScaleHeight),
m_BasisColor, BF
Line (ScaleWidth, 0)-(ScaleWidth, ScaleHeight * 0.1),
m_BasisColor
Line -(ScaleWidth * 0.9, ScaleHeight * 0.25), m_BasisColor
Line -(ScaleWidth * 0.7, ScaleHeight * 0.45), m_BasisColor
Line -(ScaleWidth * 0.55, ScaleHeight * 0.5), m_BasisColor
Line -(ScaleWidth * 0.7, ScaleHeight * 0.55), m_BasisColor
Line -(ScaleWidth * 0.9, ScaleHeight * 0.75), m_BasisColor
Line -(ScaleWidth, ScaleHeight * 0.9), m_BasisColor
Line -(ScaleWidth, ScaleHeight), m_BasisColor
Line (0, ScaleHeight)-(0, ScaleHeight * 0.9), m_BasisColor
Line -(ScaleWidth * 0.1, ScaleHeight * 0.75), m_BasisColor
Line -(ScaleWidth * 0.3, ScaleHeight * 0.55), m_BasisColor
Line -(ScaleWidth * 0.45, ScaleHeight * 0.5), m_BasisColor
Line -(ScaleWidth * 0.3, ScaleHeight * 0.45), m_BasisColor
Line -(ScaleWidth * 0.1, ScaleHeight * 0.25), m_BasisColor
Line -(0, ScaleHeight * 0.1), m_BasisColor
Line -(0, 0), m_BasisColor
Refresh
End Sub
'*****************************************************************
'События UserControl'а и pbHrglss
'*****************************************************************
Private Sub UserControl_Resize()
Dim hRgn&, numAngle&
ScaleMode = 3
DrawWidth = 2
DrawStyle = 6
AutoRedraw = True
numAngle = 17
ReDim rgnPts(0 To numAngle) As POINTAPI
rgnPts(0).X = 0
rgnPts(0).Y = 0
rgnPts(1).X = ScaleWidth
rgnPts(1).Y = 0
rgnPts(2).X = ScaleWidth
rgnPts(2).Y = ScaleHeight * 0.1
rgnPts(3).X = ScaleWidth * 0.9
rgnPts(3).Y = ScaleHeight * 0.25
rgnPts(4).X = ScaleWidth * 0.7
rgnPts(4).Y = ScaleHeight * 0.45
rgnPts(5).X = ScaleWidth * 0.55
rgnPts(5).Y = ScaleHeight * 0.5
rgnPts(6).X = ScaleWidth * 0.7
rgnPts(6).Y = ScaleHeight * 0.55
rgnPts(7).X = ScaleWidth * 0.9
rgnPts(7).Y = ScaleHeight * 0.75
rgnPts(8).X = ScaleWidth
rgnPts(8).Y = ScaleHeight * 0.9
rgnPts(9).X = ScaleWidth
rgnPts(9).Y = ScaleHeight
rgnPts(10).X = 0
rgnPts(10).Y = ScaleHeight
rgnPts(11).X = 0
rgnPts(11).Y = ScaleHeight * 0.9
rgnPts(12).X = ScaleWidth * 0.1
rgnPts(12).Y = ScaleHeight * 0.75
rgnPts(13).X = ScaleWidth * 0.3
rgnPts(13).Y = ScaleHeight * 0.55
rgnPts(14).X = ScaleWidth * 0.45
rgnPts(14).Y = ScaleHeight * 0.5
rgnPts(15).X = ScaleWidth * 0.3
rgnPts(15).Y = ScaleHeight * 0.45
rgnPts(16).X = ScaleWidth * 0.1
rgnPts(16).Y = ScaleHeight * 0.25
rgnPts(17).X = 0
rgnPts(17).Y = ScaleHeight * 0.1
hRgn = CreatePolygonRgn(rgnPts(0), numAngle + 1,
WINDING)
SetWindowRgn UserControl.hWnd, hRgn, True
DrawControl
End Sub
Private Sub UserControl_InitProperties()
m_Min = m_def_Min
m_Max = m_def_Max
m_Value = m_def_Value
m_SandColor = m_def_SandColor
m_BasisColor = m_def_BasisColor
m_Percent = m_def_Percent
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_Min = PropBag.ReadProperty("Min", m_def_Min)
m_Max = PropBag.ReadProperty("Max", m_def_Max)
m_Value = PropBag.ReadProperty("Value", m_def_Value)
UserControl.BackColor =
PropBag.ReadProperty("BackColor", &HFFFFC0)
m_SandColor = PropBag.ReadProperty("SandColor",
m_def_SandColor)
m_BasisColor = PropBag.ReadProperty("BasisColor",
m_def_BasisColor)
m_Percent = PropBag.ReadProperty("Percent",
m_def_Percent)
End Sub
Private Sub UserControl_Show()
BasisColor = m_BasisColor
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("Min", m_Min, m_def_Min)
Call PropBag.WriteProperty("Max", m_Max, m_def_Max)
Call PropBag.WriteProperty("Value", m_Value,
m_def_Value)
Call PropBag.WriteProperty("BackColor",
UserControl.BackColor, &HFFFFC0)
Call PropBag.WriteProperty("SandColor", m_SandColor,
m_def_SandColor)
Call PropBag.WriteProperty("BasisColor", m_BasisColor,
m_def_BasisColor)
End Sub