【VB】用類擴展滾動條控件 ScrollBar

原因:測試

在設計程序過程當中,常常用到滾動條控件,取值範圍常常會超過 0-32767 的範圍,若是按比例映射,又很須要最小變化值爲1的狀況,採用第三方控件當然能夠解決這個問題,卻又一般須要額外的動態連接庫的支持。ui

設想利用標準控件來擴充,使取值範圍能夠是長整數。設計

建立一個虛擬滾動條類 VirtualScroll.cls 以下: code

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測試方式:orm

(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
相關文章
相關標籤/搜索