'****************************************************************
'Проект: DblScroll
'Создан: 01.07.01
'Автор: Михаил Эскин
'****************************************************************
Option Explicit
'****************************************************************
'Тип API-функции
'****************************************************************
Private Type POINTAPI
X As Long
Y As Long
End Type
'****************************************************************
'API-функции
'****************************************************************
Private Declare Function CreateRectRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) _
As Long
Private Declare Function GetPixel Lib "gdi32" _
(ByVal hdc As Long, _
ByVal X As Long, _
ByVal Y As Long) _
As Long
Private Declare Function CombineRgn Lib "gdi32" _
(ByVal hDestRgn As Long, _
ByVal hSrcRgn1 As Long, _
ByVal hSrcRgn2 As Long, _
ByVal nCombineMode As Long) _
As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) _
As Long
Private Declare Function SetWindowRgn Lib "user32" _
(ByVal hwnd As Long, _
ByVal hRgn As Long, _
ByVal bRedraw As Long) _
As Long
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) _
As Long
'****************************************************************
'константа для API-функций
'****************************************************************
Private Const RGN_OR = 2
'****************************************************************
'Значение переменных по умолчанию
'****************************************************************
Const m_def_MinH = 0
Const m_def_MinV = 0
Const m_def_MaxH = 100
Const m_def_MaxV = 100
Const m_def_ValueH = 0
Const m_def_ValueV = 0
Const m_def_LargeChangeH = 10
Const m_def_LargeChangeV = 10
Const m_def_SmallChangeH = 1
Const m_def_SmallChangeV = 1
'****************************************************************
'Внутренние переменные событий
'****************************************************************
Dim m_MinH As Long
Dim m_MinV As Long
Dim m_MaxH As Long
Dim m_MaxV As Long
Dim m_ValueH As Long
Dim m_ValueV As Long
Dim m_LargeChangeH As Long
Dim m_LargeChangeV As Long
Dim m_SmallChangeH As Long
Dim m_SmallChangeV As Long
'****************************************************************
'Внутренние переменные программы
'****************************************************************
Private FirstPos As POINTAPI 'для перемещения формы
Private LastPos As POINTAPI 'для перемещения формы
Private startMove As Boolean 'для перемещения формы
'****************************************************************
'внутренние константы
'****************************************************************
Private Const SIGN_SIZE = 195 'высота(ширина) бегунка в твипах
Private Const SIDE_SIZE = 420 'высота(ширина) начальной части (звездочки) в твипах
'****************************************************************
'Объявление событий
'****************************************************************
Event Scroll()
Event HorizontalScroll()
Event VerticalScroll()
'****************************************************************
'Внутренние процедуры и функции, отвечающие за прозрачность
'****************************************************************
Private Sub Draw()
Dim lRgn As Long
'устанавливаем размеры контрола
Height = pic.Height
Width = pic.Width
'создаем регион
lRgn = lGetRegion(pic, vbWhite)
'прикрепляем регион к нашему окну и удаляем этот регион
SetWindowRgn hwnd, lRgn, True
DeleteObject lRgn
End Sub
Private Function lGetRegion(pic As PictureBox, lBackColor As Long) As Long
Dim lRgn As Long
Dim lSkinRgn As Long
Dim lStart As Long
Dim lX As Long
Dim lY As Long
Dim lHeight As Long
Dim lWidth As Long
Dim ms As Long
'создаем пустой регион, с которого начнем работу
lSkinRgn = CreateRectRgn(0, 0, 0, 0)
With pic
'подсчитаем размеры рисунка в Pixel
lHeight = .Height / Screen.TwipsPerPixelY
lWidth = .Width / Screen.TwipsPerPixelX
For lX = 0 To lHeight - 1
lY = 0
Do While lY < lWidth
'ищем нужный Pixel
Do While lY < lWidth And GetPixel(.hdc, lY, lX) = lBackColor
lY = lY + 1
Loop
If lY < lWidth Then
lStart = lY
Do While lY < lWidth And GetPixel(.hdc, lY, lX) <> lBackColor
lY = lY + 1
Loop
If lY > lWidth Then lY = lWidth
'нужный Pixel найден, добавим его в регион
lRgn = CreateRectRgn(lStart, lX, lY, lX + 1)
CombineRgn lSkinRgn, lSkinRgn, lRgn, RGN_OR
'удалим ненужный объект
DeleteObject lRgn
End If
Loop
Next
End With
lGetRegion = lSkinRgn
End Function
'****************************************************************
'Другие внутренние процедуры
'****************************************************************
Private Sub PosHorizontal()
picSignH.Left = (pic.ScaleWidth - (2 * SIDE_SIZE) - SIGN_SIZE)
_
* m_ValueH / (m_MaxH - m_MinH) + SIDE_SIZE
End Sub
Private Sub PosVertical()
picSignV.Top = (pic.ScaleHeight - (2 * SIDE_SIZE) - SIGN_SIZE)
_
* m_ValueV / (m_MaxV - m_MinV) + SIDE_SIZE
End Sub
Private Sub pic_MouseDown(Button As Integer, Shift As Integer,
_
X As Single, Y As Single)
If Button = vbLeftButton Then
If X > 0 And X < SIDE_SIZE Then
m_ValueH = m_ValueH - m_SmallChangeH
If m_ValueH < m_MinH Then
m_ValueH = m_MinH
End If
PosHorizontal
RaiseEvent HorizontalScroll
ElseIf X > SIDE_SIZE And X < picSignH.Left Then
m_ValueH = m_ValueH - m_LargeChangeH
If m_ValueH < m_MinH Then
m_ValueH = m_MinH
End If
PosHorizontal
RaiseEvent HorizontalScroll
ElseIf X > (picSignH.Left + picSignH.Width) And _
X < (pic.ScaleWidth - SIDE_SIZE) Then
m_ValueH = m_ValueH + m_LargeChangeH
If m_ValueH > m_MaxH Then
m_ValueH = m_MaxH
End If
PosHorizontal
RaiseEvent HorizontalScroll
ElseIf X > (pic.ScaleWidth - SIDE_SIZE) And _
X < (pic.ScaleWidth - (SIDE_SIZE / 2))
_
And Y > (pic.ScaleHeight - SIDE_SIZE) Then
m_ValueH = m_ValueH + m_SmallChangeH
If m_ValueH > m_MaxH Then
m_ValueH = m_MaxH
End If
PosHorizontal
RaiseEvent HorizontalScroll
ElseIf Y > 0 And Y < SIDE_SIZE Then
m_ValueV = m_ValueV - m_SmallChangeV
If m_ValueV < m_MinV Then
m_ValueV = m_MinV
End If
PosVertical
RaiseEvent VerticalScroll
ElseIf Y > SIDE_SIZE And Y < picSignV.Top Then
m_ValueV = m_ValueV - m_LargeChangeV
If m_ValueV < m_MinV Then
m_ValueV = m_MinV
End If
PosVertical
RaiseEvent VerticalScroll
ElseIf Y > (picSignV.Top + picSignV.Height) _
And Y < (pic.ScaleHeight - SIDE_SIZE) Then
m_ValueV = m_ValueV + m_LargeChangeV
If m_ValueV > m_MaxV Then
m_ValueV = m_MaxV
End If
PosVertical
RaiseEvent VerticalScroll
ElseIf Y > (pic.ScaleHeight - SIDE_SIZE) _
And Y < pic.ScaleHeight Then
m_ValueV = m_ValueV + m_SmallChangeV
If m_ValueV > m_MaxV Then
m_ValueV = m_MaxV
End If
PosVertical
RaiseEvent VerticalScroll
End If
SendKeys vbNullChar
RaiseEvent Scroll
End If
End Sub
'****************************************************************
'допустимые движения бегунка
'****************************************************************
Private Sub picSignMouseDown()
Dim res As Long
startMove = True
res = GetCursorPos(FirstPos)
End Sub
Private Sub picSignMouseUp()
Dim res As Long
res = GetCursorPos(LastPos)
startMove = False
End Sub
Private Sub picSignH_MouseDown(Button As Integer, Shift As Integer,
_
X As Single, Y As Single)
If Button = vbLeftButton Then
picSignMouseDown
End If
End Sub
Private Sub picSignH_MouseMove(Button As Integer, Shift As Integer,
_
X As Single, Y As Single)
Dim res As Long
If startMove Then
res = GetCursorPos(LastPos)
picSignH.Left = picSignH.Left - (FirstPos.X - LastPos.X) * _
Screen.TwipsPerPixelX
'ограничение по краям
If picSignH.Left < SIDE_SIZE Then
picSignH.Left = SIDE_SIZE
End If
If picSignH.Left > ScaleWidth - (SIDE_SIZE + SIGN_SIZE) Then
picSignH.Left = ScaleWidth - (SIDE_SIZE + SIGN_SIZE)
End If
res = GetCursorPos(FirstPos)
End If
ValueH = (m_MaxH - m_MinH) * (picSignH.Left - SIDE_SIZE) / _
(ScaleWidth - (2 * SIDE_SIZE) - SIGN_SIZE)
RaiseEvent HorizontalScroll
RaiseEvent Scroll
End Sub
Private Sub picSignH_MouseUp(Button As Integer, Shift As Integer,
_
X As Single, Y As Single)
If Button = vbLeftButton Then
picSignMouseUp
End If
End Sub
Private Sub picSignV_MouseDown(Button As Integer, Shift As Integer,
_
X As Single, Y As Single)
If Button = vbLeftButton Then
picSignMouseDown
End If
End Sub
Private Sub picSignV_MouseMove(Button As Integer, Shift As Integer,
_
X As Single, Y As Single)
Dim res As Long
If startMove Then
res = GetCursorPos(LastPos)
picSignV.Top = picSignV.Top - (FirstPos.Y - LastPos.Y) * _
Screen.TwipsPerPixelY
'ограничение по краям
If picSignV.Top < SIDE_SIZE Then
picSignV.Top = SIDE_SIZE
End If
If picSignV.Top > ScaleHeight - (SIDE_SIZE + SIGN_SIZE) Then
picSignV.Top = ScaleHeight - (SIDE_SIZE + SIGN_SIZE)
End If
res = GetCursorPos(FirstPos)
End If
ValueV = (m_MaxV - m_MinV) * (picSignV.Top - SIDE_SIZE) / _
(ScaleHeight - (2 * SIDE_SIZE) - SIGN_SIZE)
RaiseEvent VerticalScroll
RaiseEvent Scroll
End Sub
Private Sub picSignV_MouseUp(Button As Integer, Shift As Integer,
_
X As Single, Y As Single)
If Button = vbLeftButton Then
picSignMouseUp
End If
End Sub
'****************************************************************
'Свойства
'****************************************************************
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,0
Public Property Get MinH() As Long
MinH = m_MinH
End Property
Public Property Let MinH(ByVal New_MinH As Long)
m_MinH = New_MinH
PosHorizontal
PropertyChanged "MinH"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,0
Public Property Get MinV() As Long
MinV = m_MinV
End Property
Public Property Let MinV(ByVal New_MinV As Long)
m_MinV = New_MinV
PosVertical
PropertyChanged "MinV"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,100
Public Property Get MaxH() As Long
MaxH = m_MaxH
End Property
Public Property Let MaxH(ByVal New_MaxH As Long)
m_MaxH = New_MaxH
PosHorizontal
PropertyChanged "MaxH"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,100
Public Property Get MaxV() As Long
MaxV = m_MaxV
End Property
Public Property Let MaxV(ByVal New_MaxV As Long)
m_MaxV = New_MaxV
PosVertical
PropertyChanged "MaxV"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,0
Public Property Get ValueH() As Long
ValueH = m_ValueH
End Property
Public Property Let ValueH(ByVal New_ValueH As Long)
m_ValueH = New_ValueH
PosHorizontal
PropertyChanged "ValueH"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,0
Public Property Get ValueV() As Long
ValueV = m_ValueV
End Property
Public Property Let ValueV(ByVal New_ValueV As Long)
m_ValueV = New_ValueV
PosVertical
PropertyChanged "ValueV"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,10
Public Property Get LargeChangeH() As Long
LargeChangeH = m_LargeChangeH
End Property
Public Property Let LargeChangeH(ByVal New_LargeChangeH As Long)
m_LargeChangeH = New_LargeChangeH
PropertyChanged "LargeChangeH"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,10
Public Property Get LargeChangeV() As Long
LargeChangeV = m_LargeChangeV
End Property
Public Property Let LargeChangeV(ByVal New_LargeChangeV As Long)
m_LargeChangeV = New_LargeChangeV
PropertyChanged "LargeChangeV"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,1
Public Property Get SmallChangeH() As Long
SmallChangeH = m_SmallChangeH
End Property
Public Property Let SmallChangeH(ByVal New_SmallChangeH As Long)
m_SmallChangeH = New_SmallChangeH
PropertyChanged "SmallChangeH"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,1
Public Property Get SmallChangeV() As Long
SmallChangeV = m_SmallChangeV
End Property
Public Property Let SmallChangeV(ByVal New_SmallChangeV As Long)
m_SmallChangeV = New_SmallChangeV
PropertyChanged "SmallChangeV"
End Property
'****************************************************************
'Обработка событий UserControl'а
'****************************************************************
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
m_MinH = m_def_MinH
m_MinV = m_def_MinV
m_MaxH = m_def_MaxH
m_MaxV = m_def_MaxV
m_ValueH = m_def_ValueH
m_ValueV = m_def_ValueV
m_LargeChangeH = m_def_LargeChangeH
m_LargeChangeV = m_def_LargeChangeV
m_SmallChangeH = m_def_SmallChangeH
m_SmallChangeV = m_def_SmallChangeV
End Sub
'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_MinH = PropBag.ReadProperty("MinH", m_def_MinH)
m_MinV = PropBag.ReadProperty("MinV", m_def_MinV)
m_MaxH = PropBag.ReadProperty("MaxH", m_def_MaxH)
m_MaxV = PropBag.ReadProperty("MaxV", m_def_MaxV)
m_ValueH = PropBag.ReadProperty("ValueH", m_def_ValueH)
m_ValueV = PropBag.ReadProperty("ValueV", m_def_ValueV)
m_LargeChangeH = PropBag.ReadProperty("LargeChangeH", m_def_LargeChangeH)
m_LargeChangeV = PropBag.ReadProperty("LargeChangeV", m_def_LargeChangeV)
m_SmallChangeH = PropBag.ReadProperty("SmallChangeH", m_def_SmallChangeH)
m_SmallChangeV = PropBag.ReadProperty("SmallChangeV", m_def_SmallChangeV)
End Sub
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("MinH", m_MinH, m_def_MinH)
Call PropBag.WriteProperty("MinV", m_MinV, m_def_MinV)
Call PropBag.WriteProperty("MaxH", m_MaxH, m_def_MaxH)
Call PropBag.WriteProperty("MaxV", m_MaxV, m_def_MaxV)
Call PropBag.WriteProperty("ValueH", m_ValueH, m_def_ValueH)
Call PropBag.WriteProperty("ValueV", m_ValueV, m_def_ValueV)
Call PropBag.WriteProperty("LargeChangeH", m_LargeChangeH, m_def_LargeChangeH)
Call PropBag.WriteProperty("LargeChangeV", m_LargeChangeV, m_def_LargeChangeV)
Call PropBag.WriteProperty("SmallChangeH", m_SmallChangeH, m_def_SmallChangeH)
Call PropBag.WriteProperty("SmallChangeV", m_SmallChangeV, m_def_SmallChangeV)
End Sub
Private Sub UserControl_Show()
Draw
End Sub