原因:測試
在設計程序過程當中,常常用到滾動條控件,取值範圍常常會超過 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