Листинг для Урока 10
ActiveX Control "FigureControl"
'*****************************************************************
'Урок
10
'ActiveX Control - "FigureControl"
'Листинг
'*****************************************************************
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 Type POINTAPI
X As Long
Y As Long
End Type
'*****************************************************************
'Объявление внутренних переменных
'*****************************************************************
Private rgn() As POINTAPI
Private FirstAdding As Boolean
Private rgnItemX() As Long
Private rgnItemY() As Long
'*****************************************************************
'Объявление нумерованных констант
'*****************************************************************
Public Enum constOrientation
Horizontal = 0
Vertical = 1
End Enum
'*****************************************************************
'Объявление констант и переменных
'*****************************************************************
Const m_def_Caption = "FigureControl"
Const m_def_ForeColor = &HFFFF&
Const m_def_Gradient = True
Const m_def_GradientRed = 0
Const m_def_GradientGreen = 0
Const m_def_GradientBlue = -1
Const m_def_GradientOrientation = 0
Const m_def_BorderColor = &H808080
Const m_def_BorderThickness = 2
Dim m_Caption As String
Dim m_ForeColor As OLE_COLOR
Dim m_BorderColor As OLE_COLOR
Dim m_BorderThickness As Integer
Dim m_Gradient As Boolean
Dim m_GradientRed As Integer
Dim m_GradientGreen As Integer
Dim m_GradientBlue As Integer
Dim m_GradientOrientation As constOrientation
'*****************************************************************
'Объявление
событий
'*****************************************************************
Event Click()
Event DblClick()
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyPress(KeyAscii As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
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)
'*****************************************************************
'Внутренние функции и процедуры
'*****************************************************************
Private Function PointCount() As Integer
PointCount = UBound(rgnItemX)
End Function
Private Sub DrawControl()
Cls
If m_Gradient = True Then
Dim R%, G%, B%
Dim i%, NbrRects%, GradValue%, GradColor&
NbrRects% = 127
ScaleMode = 3
DrawWidth = 2
DrawStyle = 6
AutoRedraw = True
For i = 1 To NbrRects
GradValue = 255 - (i * 2 - 1)
If m_GradientRed = -1 Then
R = GradValue
Else
R = m_GradientRed
End If
If m_GradientGreen = -1 Then
G = GradValue
Else
G = m_GradientGreen
End If
If m_GradientBlue = -1 Then
B = GradValue
Else
B = m_GradientBlue
End If
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
CurrentY = (ScaleHeight - TextHeight(m_Caption)) / 2
UserControl.ForeColor = m_ForeColor
UserControl.Print m_Caption
ShowFigure
End Sub
'*****************************************************************
'Методы
контрола
'*****************************************************************
Public Sub AddPoint(ByVal X As Long, ByVal Y As Long)
Dim i As Integer
i = UBound(rgnItemX)
If FirstAdding Then
i = 0
FirstAdding = False
Else
i = i + 1
End If
ReDim Preserve rgnItemX(i)
ReDim Preserve rgnItemY(i)
rgnItemX(i) = X
rgnItemY(i) = Y
End Sub
Public Sub Refresh()
UserControl.Refresh
End Sub
Public Sub ShowFigure()
Dim i As Integer, count As Long, hRgn As Long
On Error Resume Next
count = PointCount + 1
ReDim rgn(count) As POINTAPI
For i = 1 To count
rgn(i).X = rgnItemX(i - 1)
rgn(i).Y = rgnItemY(i - 1)
Next
hRgn = CreatePolygonRgn(rgn(1), count, 0)
SetWindowRgn UserControl.hWnd, hRgn, True
DrawWidth = m_BorderThickness
For i = 1 To count
If i = count Then
Line (rgn(i).X, rgn(i).Y)-(rgn(1).X, rgn(1).Y), m_BorderColor
Else
Line (rgn(i).X, rgn(i).Y)-(rgn(i + 1).X, rgn(i + 1).Y), m_BorderColor
End If
Next
End Sub
Public Sub About()
frmAbout.Show vbModal
End Sub
'*****************************************************************
'Обработка событий контрола
'*****************************************************************
Private Sub UserControl_Click()
RaiseEvent Click
End Sub
Private Sub UserControl_DblClick()
RaiseEvent DblClick
End Sub
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyDown(KeyCode, Shift)
End Sub
Private Sub UserControl_KeyPress(KeyAscii As Integer)
RaiseEvent KeyPress(KeyAscii)
End Sub
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyUp(KeyCode, Shift)
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_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseMove(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 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"
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
PropertyChanged "Gradient"
DrawControl
End Property
Public Property Get GradientRed() As Integer
GradientRed = m_GradientRed
End Property
Public Property Let GradientRed(ByVal New_GradientRed As Integer)
If New_GradientRed < 0 Or New_GradientRed > 255 Then
New_GradientRed = -1
End If
m_GradientRed = New_GradientRed
PropertyChanged "GradientRed"
DrawControl
End Property
Public Property Get GradientGreen() As Integer
GradientGreen = m_GradientGreen
End Property
Public Property Let GradientGreen(ByVal New_GradientGreen As Integer)
If New_GradientGreen < 0 Or New_GradientGreen > 255 Then
New_GradientGreen = -1
End If
m_GradientGreen = New_GradientGreen
PropertyChanged "GradientGreen"
DrawControl
End Property
Public Property Get GradientBlue() As Integer
GradientBlue = m_GradientBlue
End Property
Public Property Let GradientBlue(ByVal New_GradientBlue As Integer)
If New_GradientBlue < 0 Or New_GradientBlue > 255 Then
New_GradientBlue = -1
End If
m_GradientBlue = New_GradientBlue
PropertyChanged "GradientBlue"
DrawControl
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
PropertyChanged "GradientOrientation"
DrawControl
End Property
Public Property Get BorderColor() As OLE_COLOR
BorderColor = m_BorderColor
End Property
Public Property Let BorderColor(ByVal New_BorderColor As OLE_COLOR)
m_BorderColor = New_BorderColor
PropertyChanged "BorderColor"
End Property
Public Property Get BorderThickness() As Integer
BorderThickness = m_BorderThickness
End Property
Public Property Let BorderThickness(ByVal New_BorderThickness As Integer)
m_BorderThickness = New_BorderThickness
PropertyChanged "BorderThickness"
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
PropertyChanged "Caption"
DrawControl
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
PropertyChanged "Font"
DrawControl
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor = m_ForeColor 'UserControl.ForeColor
End Property
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
m_ForeColor = New_ForeColor
PropertyChanged "ForeColor"
DrawControl
End Property
'*****************************************************************
'Обработка событий UserControl
'*****************************************************************
Private Sub UserControl_Initialize()
ReDim rgnItemX(0)
ReDim rgnItemY(0)
FirstAdding = True
End Sub
Private Sub UserControl_InitProperties()
m_Gradient = m_def_Gradient
m_GradientRed = m_def_GradientRed
m_GradientGreen = m_def_GradientGreen
m_GradientBlue = m_def_GradientBlue
m_GradientOrientation = m_def_GradientOrientation
m_BorderColor = m_def_BorderColor
m_BorderThickness = m_def_BorderThickness
m_Caption = m_def_Caption
m_ForeColor = m_def_ForeColor
Set UserControl.Font = Ambient.Font
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
UserControl.BackColor = PropBag.ReadProperty("BackColor", &HFFFFC0)
m_Gradient = PropBag.ReadProperty("Gradient", m_def_Gradient)
m_GradientRed = PropBag.ReadProperty("GradientRed", m_def_GradientRed)
m_GradientGreen = PropBag.ReadProperty("GradientGreen", m_def_GradientGreen)
m_GradientBlue = PropBag.ReadProperty("GradientBlue", m_def_GradientBlue)
m_GradientOrientation = PropBag.ReadProperty("GradientOrientation", m_def_GradientOrientation)
m_BorderColor = PropBag.ReadProperty("BorderColor", m_def_BorderColor)
m_BorderThickness = PropBag.ReadProperty("BorderThickness", m_def_BorderThickness)
Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
m_ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
m_Caption = PropBag.ReadProperty("Caption", m_def_Caption)
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("BackColor", UserControl.BackColor, &HFFFFC0)
Call PropBag.WriteProperty("Gradient", m_Gradient, m_def_Gradient)
Call PropBag.WriteProperty("GradientRed", m_GradientRed, m_def_GradientRed)
Call PropBag.WriteProperty("GradientGreen", m_GradientGreen, m_def_GradientGreen)
Call PropBag.WriteProperty("GradientBlue", m_GradientBlue, m_def_GradientBlue)
Call PropBag.WriteProperty("GradientOrientation", m_GradientOrientation, m_def_GradientOrientation)
Call PropBag.WriteProperty("BorderColor", m_BorderColor, m_def_BorderColor)
Call PropBag.WriteProperty("BorderThickness", m_BorderThickness, m_def_BorderThickness)
Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
Call PropBag.WriteProperty("ForeColor", m_ForeColor, &H80000012)
Call PropBag.WriteProperty("Caption", m_Caption, m_def_Caption)
End Sub