Листинг для Урока 9
ActiveX Control "Ruler"
'*****************************************************************
'Урок
9
'ActiveX Control - "Ruler"
'Листинг
'*****************************************************************
Option Explicit
'*****************************************************************
'Объявление API-функций
'*****************************************************************
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
ByVal nIndex As Long) As Long
'*****************************************************************
'Объявление
констант
'*****************************************************************
Private Const LOGPIXELSX = 88 ' число пикселей на дюйм по горизонтали
Private Const LOGPIXELSY = 90 ' число линий растра на дюйм по вертикали
'*****************************************************************
'Объявление
нумерованных
констант
'*****************************************************************
Public Enum constMeasurement
сантиметры = 0
дюймы = 1
End Enum
Public Enum constOrientation
горизонтальный = 0
вертикальный = 1
End Enum
'*****************************************************************
'Объявление
констант и
переменных
'*****************************************************************
Const m_def_Orientation = 0
Const m_def_ForeColor = &H0&
Const m_def_Measurement = 0
Dim m_Orientation As constOrientation
Dim m_ForeColor As OLE_COLOR
Dim m_Measurement As constMeasurement
'*****************************************************************
'Объявление
событий
'*****************************************************************
Event Click()
Event DblClick()
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 Sub ShowRuler()
Dim inch, cm, i%, countmark%, extent%, mark%, whole%, Measur As constMeasurement
Dim OrientX&, OrientY&, LogPixelsXY
Cls
Select Case m_Orientation
Case 0
OrientX = ScaleWidth
OrientY = ScaleHeight
LogPixelsXY = LOGPIXELSX
Case 1
OrientX = ScaleHeight
OrientY = ScaleWidth
LogPixelsXY = LOGPIXELSY
End Select
inch = GetDeviceCaps(UserControl.hdc, LogPixelsXY)
cm = inch / 2.54
Select Case m_Measurement
Case 0
Measur = cm
Case 1
Measur = inch
End Select
For i = 0 To OrientX Step (Measur / 10)
Select Case True
Case countmark / 10 = Int(countmark / 10)
extent = OrientY / 7 * 4
mark = 1
Case countmark / 5 = Int(countmark / 5)
extent = OrientY / 7 * 3
Case Else
extent = OrientY / 7 * 2
End Select
UserControl.ForeColor = m_ForeColor
Select Case m_Orientation
Case 0
Line (i, OrientY)-(i, OrientY - extent), m_ForeColor
If mark = 1 Then
CurrentX = CurrentX - 7
CurrentY = CurrentY - 15
If whole > 0 Then Print whole
whole = whole + 1
End If
Case 1
Line (OrientY, i)-(OrientY - extent, i), m_ForeColor
If mark = 1 Then
CurrentX = CurrentX - 15
CurrentY = CurrentY - 7
If whole > 0 Then Print whole
whole = whole + 1
End If
End Select
countmark = countmark + 1
mark = 0
Next
End Sub
'*****************************************************************
'Свойства
'*****************************************************************
Public Property Get Orientation() As constOrientation
Orientation = m_Orientation
End Property
Public Property Let Orientation(ByVal New_Orientation As constOrientation)
m_Orientation = New_Orientation
PropertyChanged "Orientation"
ShowRuler
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"
ShowRuler
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"
ShowRuler
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
PropertyChanged "ForeColor"
ShowRuler
End Property
Public Property Get Measurement() As constMeasurement
Measurement = m_Measurement
End Property
Public Property Let Measurement(ByVal New_Measurement As constMeasurement)
m_Measurement = New_Measurement
PropertyChanged "Measurement"
ShowRuler
End Property
'*****************************************************************
'Обработка
событий UserControl
и контрола
Ruler
'*****************************************************************
Private Sub UserControl_Click()
RaiseEvent Click
End Sub
Private Sub UserControl_DblClick()
RaiseEvent DblClick
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
Private Sub UserControl_InitProperties()
Set UserControl.Font = Ambient.Font
m_ForeColor = m_def_ForeColor
m_Measurement = m_def_Measurement
m_Orientation = m_def_Orientation
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
UserControl.BackColor = PropBag.ReadProperty("BackColor", &H80000005)
Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
m_ForeColor = PropBag.ReadProperty("ForeColor", m_def_ForeColor)
m_Measurement = PropBag.ReadProperty("Measurement", m_def_Measurement)
m_Orientation = PropBag.ReadProperty("Orientation", m_def_Orientation)
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H80000005)
Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
Call PropBag.WriteProperty("ForeColor", m_ForeColor, m_def_ForeColor)
Call PropBag.WriteProperty("Measurement", m_Measurement, m_def_Measurement)
Call PropBag.WriteProperty("Orientation", m_Orientation, m_def_Orientation)
End Sub
Private Sub UserControl_Show()
ShowRuler
End Sub
Private Sub UserControl_Resize()
ShowRuler
End Sub