【VB】用类扩展滚动条控件 ScrollBar

缘由:

在设计程序过程中，经常用到滚动条控件，取值范围经常会超过 0-32767 的范围，如果按比例映射，又很需要最小变化值为1的情况，采用第三方控件固然可以解决这个问题，却又通常需要额外的动态链接库的支持。

设想利用标准控件来扩充，使取值范围可以是长整数。

创建一个虚拟滚动条类 VirtualScroll.cls 如下: 

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "VirtualScroll"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
' 利用标准滚动条设计的虚拟滚动条
' 滚动范围为长整数，可以是负数
'
' 使用方法:
' (1)在工程中添加类 VirtualScroll 和标准滚动条控件 mScro
' (2)定义虚拟滚动条 vScro(或其它名称亦可):
'    Dim WithEvents vScro As VirtualScroll
' (3)关联控件和虚拟滚动条
'    Associate(ScrollControl As VScrollBar, Optional Min As Long = 0, Optional Max As Long = 0, _
'        Optional Value As Long = 0, Optional SmallChange As Long = 0, Optional LargeChange As Long = 0)
'    Min, Max, Value 均为 0 时，从控件中获取所有值(包括小变化值和大变化值)
' (4)事件处理:
'    ' 滚动值改变事件(单击“箭头”、“滚动块和上箭头之间的区域”或“滚动块和下箭头之间的区域”时发生)
'    Private Sub vScro_Change()
'        Debug.Print "Virtual Change:" & vScro.Value
'    End Sub
'
'    ' 滚动事件(拖动滚动块时发生)
'    Private Sub vScro_Scroll()
'        Debug.Print "Virtual Scroll:" & vScro.Value
'    End Sub
' (5)属性设置和获取:
'    vScro.Min = 最小值
'    vScro.Max = 最大值
'    vScro.Value = 当前值
'    vScro.SmallChange = 小变化值
'    vScro.LargeChange = 大变化值
'    vScro.Left = 控件的左侧坐标
'    vScro.Top = 控件的上端坐标
'    vScro.Width = 控件的宽度
'    vScro.Height = 控件的高度
'    vScro.Enabled = 控件启用状态
'    vScro.Visible = 控件可见状态
' (6)方法:
'    vScro.SetFocus = 设置控件获得焦点
'    Associate(ScrollControl As VScrollBar, Optional Min As Long = 0, Optional Max As Long = 0, _
'        Optional Value As Long = 0, Optional SmallChange As Long = 0, Optional LargeChange As Long = 0)
'        关联控件和虚拟滚动条
'        Min, Max, Value 均为 0 时，从控件中获取所有值(包括小变化值和大变化值)
'
' 注意:
' (1)设置数值超出范围时，自动调整到最接近的边界
' (2)小变化值和大变化值都必须大于 1，如果小于 1 则自动调整到合法值
' (3)小变化、大变化和设定值都可以准确表现(比如范围为 -65536 和 150000 之间，小变化=1，大变化=10，则单击箭头将变化 1，按上下段将变化 10, 这是通过变化大小测定的)
' (4)拖动值则只能通过计算大致得出(无法一一对应)
' (5)最小值和最大值可以随意设置, 但仅支持到长整数(-2147483648 和 2147483647 之间的值), 设置边界时，同时校正虚拟滚动条的数值
'
Option Explicit

'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent Change[(arg1, arg2, ... , argn)]
Public Event Change()

'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent Scroll[(arg1, arg2, ... , argn)]
Public Event Scroll()

'保持属性值的局部变量
Private mEnabled As Boolean         ' 控件的启用值
Private mVisible As Long            ' 控件的可见值
Private mLarge As Long              ' 大变化值
Private mMax As Long                ' 最大值
Private mMin As Long                ' 最小值
Private mSmall As Long              ' 小变化值
Private mValue As Long              ' 实际值
Private mIsNotEvent As Boolean      ' 检测是否事件(执行值改变的动作 或 仅设置滚动条的值)
Private WithEvents mScrollBar As VScrollBar    ' 滚动条对象
Attribute mScrollBar.VB_VarHelpID = -1
Private ScroScale As Double         ' 转换比例
Private ScroMin As Long             ' 滚动条最小值
Private ScroMax As Long             ' 滚动条最大值
Private ScroValue As Long           ' 滚动条当前值
Private ScroSmall As Long           ' 小变化值
Private ScroLarge As Long           ' 大变化值

Private MinBound As Long            ' 小边界(设置此值方可处理最小值大于最大值的情况)
Private MaxBound As Long            ' 大边界(设置此值方可处理最小值大于最大值的情况)
Private IsAssociated As Boolean     ' 是否已经关联

Private Sub Class_Initialize()
    IsAssociated = False
    mMin = 0
    mMax = 65536
    mSmall = 1
    mValue = 0
    MinBound = 0
    MaxBound = 65536
    mIsNotEvent = False
    Set mScrollBar = Nothing
    mLarge = 10
End Sub

Private Sub Class_Terminate()
    Set mScrollBar = Nothing
End Sub

Private Sub mScrollBar_Change()
' 接管滚动条的改变事件
    Change
End Sub

Private Sub mScrollBar_Scroll()
' 接管滚动条的滚动事件
    Scroll
End Sub

Public Sub SetFocus()
    If IsAssociated Then
        mScrollBar.SetFocus
    End If
End Sub

Public Sub Associate(ScrollControl As VScrollBar, Optional Min As Long = 0, Optional Max As Long = 0, Optional Value As Long = 0, Optional SmallChange As Long = 0, Optional LargeChange As Long = 0)
    Set mScrollBar = ScrollControl
    ScroMin = mScrollBar.Min
    ScroMax = mScrollBar.Max
    ScroValue = mScrollBar.Value
    ScroSmall = mScrollBar.SmallChange
    ScroLarge = mScrollBar.LargeChange

    If Min = 0 And Max = 0 And Value = 0 Then
        ' 全部使用控件的设置
        mMin = ScroMin
        mMax = ScroMax
        mValue = ScroValue
        mSmall = ScroSmall
        mLarge = ScroLarge
        ScroScale = 1
        MinBound = MinValue(Min, Max)
        MaxBound = MaxValue(Min, Max)
    Else
        mMin = Min
        mMax = Max
        MinBound = MinValue(Min, Max)
        MaxBound = MaxValue(Min, Max)
        If Value < MinBound Then
            ' 指定值小于最小值时取最小值
            Value = MinBound
        End If
        If Value > MaxBound Then
            ' 指定值大于最大值时取最大值
            Value = MaxBound
        End If
        If SmallChange <= 0 Then
            SmallChange = 1
        End If
        If LargeChange <= 0 Then
            LargeChange = 1
        End If
        mValue = Value
        mSmall = SmallChange
        mLarge = LargeChange
        CalcScale
    End If
    IsAssociated = True
End Sub

Private Sub CalcScale()
    Dim lngValue1 As Long
    Dim lngValue2 As Long
    Dim newScroValue As Long
    If Abs(mMax - mMin) > 32767 Then                                ' 数值范围大小超过标准控件的数值范围大小
        ScroScale = CDbl(Abs(mMax - mMin)) / 32767#                 ' 计算比例
        If mMin <= mMax Then
            ScroMin = 0                                             ' 控件的最小值为 0
            ScroMax = 32767                                         ' 控件的最大值为 32767(最大)
        Else
            ScroMin = 32767                                         ' 控件的最小值为 0
            ScroMax = 0                                             ' 控件的最大值为 32767(最大)
        End If
        newScroValue = Fix((mValue - MinBound) / ScroScale)             ' 根据数值计算控件的数值
        lngValue1 = Fix(mSmall / ScroScale)                         ' 根据小变化值计算控件的小变化值
        If lngValue1 < 1 Then lngValue1 = 1                         ' 控件的小变化值最小为 1
        lngValue2 = Fix(mLarge / ScroScale)                         ' 根据大变化值计算控件的大变化值
        If lngValue2 < 1 Then lngValue2 = 1                         ' 控件的大变化值最小为 1
        If lngValue2 = lngValue1 Then                               ' 当计算出的控件的小变化值和大变化值相同时
            If mSmall <> mLarge Then                                ' 如果虚拟的小变化值和大变化值不同
                lngValue2 = lngValue1 + Sgn(mLarge - mSmall)        ' 则在原值的基础上调整大变化值为(+-1)
                If lngValue2 < 1 Then                               ' 但仍然都不能小于 1(大变化值小于小变化值时出现)
                    lngValue1 = lngValue1 + 1
                    lngValue2 = lngValue2 + 1
                End If
            End If
        End If
        ScroSmall = lngValue1
        ScroLarge = lngValue2
    Else
        ScroScale = 1
        ' 此处将控件的范围调整到 0-差值 之间(即最小/最大值总是 0-n 或者 n-0, n=0-32767)
        If mMin <= mMax Then
            ScroMin = 0
            ScroMax = mMax - mMin                                   ' 范围为超出时仅调整最大值和最小值的范围
            newScroValue = mValue - mMin
        Else
            ScroMin = mMin - mMax
            ScroMax = 0
            newScroValue = mValue - mMax
        End If
        ScroSmall = mSmall
        ScroLarge = mLarge
    End If
    mScrollBar.Min = ScroMin                                        ' 将计算的值赋给控件
    mScrollBar.Max = ScroMax
    mScrollBar.SmallChange = ScroSmall
    mScrollBar.LargeChange = ScroLarge
    SetScrollValue newScroValue
End Sub

Private Sub SetScrollValue(Value As Long)
    ' 用这个字程序设置滚动条的值不再进行转换
    ' 在事件中检测到为非事件时不做事件处理
    ' 在控件的事件中应该调用本类的 Scroll
    Dim ScroMinValue As Long
    Dim ScroMaxValue As Long
    ScroMinValue = MinValue(ScroMin, ScroMax)
    ScroMaxValue = MaxValue(ScroMin, ScroMax)
    If Value < ScroMinValue Then
        Value = ScroMinValue
    End If
    If Value > ScroMaxValue Then
        Value = ScroMaxValue
    End If
    
    ' 边界附近的处理(在超出 32767 时方能发生)
    ' 如果控件的值达到边界，而虚拟滚动条的值尚未达到边界
    ' 则需要将控件的值移动到于边界一个单位的距离
    ' 以免无法通过箭头或点击上下的空白区域改变虚拟滚动条的值
    If Value = ScroMaxValue And mValue < MaxBound Then
        Value = ScroMaxValue - 1
    ElseIf Value = ScroMinValue And mValue > MinBound Then
        Value = ScroMinValue + 1
    End If
    ' 这里一定要强制设置，因为总是可能与滚动条的实际值不同
    ScroValue = Value
    If mScrollBar.Value <> Value Then                               ' 控件的当前值和要赋给的值不同时
        mIsNotEvent = True                                          ' 设置完后将产生事件，设置标志不进行回设
        mScrollBar.Value = Value
        DoEvents
        mIsNotEvent = False
    End If
End Sub

Private Sub ChangeOrScroll(IsChange As Boolean)
    ' 本字程序用于将滚动条的值换算成虚拟值并重设滚动条的值
    Dim CurScrollValue As Long
    Dim newScroValue As Long
    If (Not IsAssociated) Or mIsNotEvent Then
        ' 未关联，或者:
        ' 根据设定的值设置滚动位置时，会发生滚动或者修改事件
        ' 此时应该会调用本程序进行校正
        ' 非来自于键盘和鼠标事件，因此不再设置滚动条的状态
        ' 表明仅仅设置滚动条的值
        ' 不再重新计算和设定
        Exit Sub
    End If
    CurScrollValue = mScrollBar.Value
    If CurScrollValue = ScroValue Then Exit Sub ' 不会发生
    If Abs(CurScrollValue - ScroValue) = ScroSmall Then
        mValue = mValue + Sgn(CurScrollValue - ScroValue) * mSmall
    ElseIf Abs(CurScrollValue - ScroValue) = ScroLarge Then
        mValue = mValue + Sgn(CurScrollValue - ScroValue) * mLarge
    ElseIf CurScrollValue = ScroMin Then
        ' 到达边界时，通过计算可能出现无法达到边界的情况
        mValue = mMin
    ElseIf CurScrollValue = ScroMax Then
        ' 到达边界时，通过计算可能出现无法达到边界的情况
        mValue = mMax
    Else
        mValue = Fix(CurScrollValue * ScroScale) + MinBound
    End If
    If mValue < MinBound Then mValue = MinBound
    If mValue > MaxBound Then mValue = MaxBound
    newScroValue = Fix((mValue - MinBound) / ScroScale)
    SetScrollValue newScroValue
    If IsChange Then                                                ' 激发改变事件
        RaiseEvent Change
    Else
        RaiseEvent Scroll                                           ' 激发滚动事件
    End If
End Sub

Public Sub Change()
    ChangeOrScroll True
End Sub

Public Sub Scroll()
    ChangeOrScroll False
End Sub

'Public Property Let IsNotEvent(ByVal ManualAction As Boolean)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.IsNotEvent = 5
'    mIsNotEvent = ManualAction
'End Property

'Public Property Get IsNotEvent() As Boolean
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.IsNotEvent
'    IsNotEvent = mIsNotEvent
'End Property

Public Property Let Value(ByVal ScrollValue As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Value = 5
    Dim newScroValue As Long
    If (Not IsAssociated) Or ScrollValue = mValue Then
        Exit Property
    End If
    mValue = ScrollValue
    If (mValue < MinBound) Then mValue = MinBound
    If (mValue > MaxBound) Then mValue = MaxBound
    newScroValue = Fix((mValue - MinBound) / ScroScale)
    SetScrollValue newScroValue
End Property

Public Property Get Value() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Value
    Value = mValue
End Property

Private Sub CalcChange()
    Dim lngValue1 As Long
    Dim lngValue2 As Long
    If Abs(ScroScale - 1) > 0.00001 Then
        lngValue1 = Fix(mSmall / ScroScale)
        If lngValue1 < 1 Then lngValue1 = 1
        ScroSmall = lngValue1
        lngValue2 = Fix(mLarge / ScroScale)
        If lngValue2 = lngValue1 Then
            If mSmall <> mLarge Then
                lngValue2 = lngValue1 + Sgn(mLarge - mSmall)
            End If
        End If
        ScroLarge = lngValue2
    Else
        ScroSmall = mSmall
        ScroLarge = mLarge
        If ScroSmall < 1 Then ScroSmall = 1
        If ScroLarge < ScroSmall Then ScroLarge = ScroSmall
    End If
    mScrollBar.SmallChange = ScroSmall
    mScrollBar.LargeChange = ScroLarge
End Sub

Public Property Let Enabled(ByVal EnableValue As Boolean)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Enabled = True
    If IsAssociated Then
        mEnabled = EnableValue
        mScrollBar.Enabled = mEnabled
    End If
End Property

Public Property Get Enabled() As Boolean
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Enabled
    If IsAssociated Then
        mEnabled = mScrollBar.Enabled
        Enabled = mEnabled
    End If
End Property

Public Property Let Visible(ByVal VisibleValue As Boolean)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Visible = True
    If IsAssociated Then
        mVisible = VisibleValue
        mScrollBar.Visible = mVisible
    End If
End Property

Public Property Get Visible() As Boolean
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Visible
    If IsAssociated Then
        mVisible = mScrollBar.Visible
        Visible = mVisible
    End If
End Property

Public Property Let Left(ByVal mLeft As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Left = 5
    If IsAssociated Then
        mScrollBar.Left = mLeft
    End If
End Property

Public Property Get Left() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Left
    If IsAssociated Then
        Left = mScrollBar.Left
    End If
End Property

Public Property Let Top(ByVal mTop As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Top = 5
    If IsAssociated Then
        mScrollBar.Top = mTop
    End If
End Property

Public Property Get Top() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Top
    If IsAssociated Then
        Top = mScrollBar.Top
    End If
End Property

Public Property Let Width(ByVal mWidth As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Width = 5
    If IsAssociated Then
        mScrollBar.Width = mWidth
    End If
End Property

Public Property Get Width() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Width
    If IsAssociated Then
        Width = mScrollBar.Width
    End If
End Property

Public Property Let Height(ByVal mHeight As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Height = 5
    If IsAssociated Then
        mScrollBar.Height = mHeight
    End If
End Property

Public Property Get Height() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Height
    If IsAssociated Then
        Height = mScrollBar.Height
    End If
End Property

Public Property Let Min(ByVal ScrollMin As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Min = 5
' 单独设置时，不能让最小值大于当前最大值
    If (Not IsAssociated) Or ScrollMin = mMin Then
        Exit Property
    End If
    mMin = ScrollMin
    MinBound = MinValue(mMin, mMax)
    MaxBound = MaxValue(mMin, mMax)
    If mValue < MinBound Then
        mValue = MinBound
    End If
    If mValue > MaxBound Then
        mValue = MaxBound
    End If
    CalcScale
End Property

Public Property Get Min() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Min
    Min = mMin
End Property

Public Property Let Max(ByVal ScrollMax As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Max = 5
' 单独设置时，不能让最大值小于当前最小值
    If (Not IsAssociated) Or ScrollMax = mMax Then
        Exit Property
    End If
    mMax = ScrollMax
    MinBound = MinValue(mMin, mMax)
    MaxBound = MaxValue(mMin, mMax)
    If mValue < MinBound Then
        mValue = MinBound
    End If
    If mValue > MaxBound Then
        mValue = MaxBound
    End If
    CalcScale
End Property

Public Property Get Max() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Max
    Max = mMax
End Property

Public Property Let SmallChange(ByVal ScrollSmall As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.LargeChange = 5
    If (Not IsAssociated) Or ScrollSmall = mSmall Then
        Exit Property
    End If
    mSmall = ScrollSmall
    CalcChange
End Property

Public Property Get SmallChange() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.SmallChange
    SmallChange = mSmall
End Property

Public Property Let LargeChange(ByVal ScrollLarge As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.LargeChange = 5
    If (Not IsAssociated) Or ScrollLarge = mLarge Then
        Exit Property
    End If
    mLarge = ScrollLarge
    CalcChange
End Property

Public Property Get LargeChange() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.LargeChange
    LargeChange = mLarge
End Property

Private Function MinValue(a As Variant, b As Variant) As Variant
    MinValue = IIf(a < b, a, b)
End Function

Private Function MaxValue(a As Variant, b As Variant) As Variant
    MaxValue = IIf(a > b, a, b)
End Function

 

VB测试方式:

(1)在VB窗体中添加一个滚动条控件，名称为mScro，两个命令按钮 Command1 和 Command2, 在工程中添加虚拟滚动条类 VirtualScroll.cls

(2)窗体代码:

Option Explicit

Dim WithEvents vScro As VirtualScroll

Private Sub Command1_Click()
    vScro.Value = 12345
    Debug.Print "Virtual => Min: " & vScro.Min & ", Max: " & vScro.Max & ", Value: " & vScro.Value
End Sub

Private Sub Command2_Click()
    Debug.Print "Control => Min: " & mScro.Min & ", Max: " & mScro.Max & ", Value: " & mScro.Value
    Debug.Print "Virtual => Min: " & vScro.Min & ", Max: " & vScro.Max & ", Value: " & vScro.Value
End Sub

Private Sub Form_Load()
    Set vScro = New VirtualScroll
    vScro.Associate mScro, 65536, -65536, 65536, 1, 10
    vScro.Min = 32768
End Sub

Private Sub vScro_Change()
    Debug.Print "Virtual Change:" & vScro.Value
End Sub

Private Sub vScro_Scroll()
    Debug.Print "Virtual Scroll:" & vScro.Value
End Sub