VB6給控件增加一個滾動事件

日期：2019年12月12日
作者：Commas
註釋：VB6的控件本身是不支持鼠標滾輪滾動的事件，以前寫的代碼有點low，參考了一個大神的代碼，重新寫了一個類模塊用來支持滾動事件，記錄一下……
【資源下載】

---

---

一、效果

1. 窗體上放一個text控件，命名爲txtNum
   
2. txtNum響應鼠標滾輪滾動，我做了一個前滾+1，後滾-1的操作，顯示在txtNum.text裏面。想要實現什麼效果，自行更改txtNum_MouseWheel()子過程（寫成了和事件一樣的格式，目的很簡單，爲了統一風格）。
   （i）鼠標滾輪向前滾動示意圖
   變化範圍：-2→2
   
   （ii）鼠標滾輪向後滾動示意圖
   變化範圍：2→-2
   

二、原理

本質：
1、Hook消息處理函數
2、自己處理想要處理的消息（自定義的消息），比如做一個“鼠標滾輪的滾動事件”

三、代碼

1. Demo窗體代碼

Option Explicit

Private Sub Form_Load()
On Error Resume Next
    Call BindMyWndProc(Me)
End Sub

2. 類模塊代碼

Option Explicit

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const GWL_WNDPROC = (-4)
Private Const WM_MOUSEWHEEL As Long = &H20A& ' 滾輪事件的消息
Private Const WHEEL_DELTA = 120

'需要增加滾輪事件的控件相關變量
Private txtNum_hWnd As Long                  'txtNum的hWnd值
Private txtNum_OldWndProc As Long            'txtNum的舊消息處理函數的地址
Private oContainer As Object

'初始化操作（綁定容器對象，指定接收消息的對象），控件才能識別鼠標滾輪。
Public Sub BindMyWndProc(ByRef objContainer As Object)
On Error Resume Next
    Set oContainer = objContainer'設置容器窗體
    '（1）txtNum
    txtNum_hWnd = oContainer.txtNum.hWnd
    txtNum_OldWndProc = GetWindowLong(txtNum_hWnd, GWL_WNDPROC)                 '取得原先的消息處理函數的入口
    SetWindowLong txtNum_hWnd, GWL_WNDPROC, AddressOf registerWindowMessage      '接收自定義消息處理函數
    '（2）其它控件
End Sub

'自定義消息處理函數
Private Function registerWindowMessage(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
    If Msg = WM_MOUSEWHEEL Then  '（1）滾輪消息
        Dim lngDelta As Long, lngButton As Long, lngX As Long, lngY As Long
        lngButton = wParam And &HFFFF&
        lngDelta = wParam \ &H10000
        lngX = lParam And &HFFFF&
        lngY = lParam \ &H10000

        '（1-1）txtNum控件的消息
        If hWnd = txtNum_hWnd Then Call txtNum_MouseWheel(lngDelta, lngButton, lngX, lngY)
        '（1-2）其它控件的消息，若有則繼續
    Else                            '（2）其它消息：原路走xxx_OldWndProc
        '（2-1）txtNum控件的消息
        If hWnd = txtNum_hWnd Then registerWindowMessage = CallWindowProc(txtNum_OldWndProc, hWnd, Msg, wParam, lParam)
'''        '（2-2）其它控件的消息，若有則繼續
    End If
    
End Function

'需要實現的“txtNum滾輪事件”
Private Sub txtNum_MouseWheel(ByVal Delta As Long, ByVal Button As Long, ByVal X As Long, ByVal Y As Long)
On Error Resume Next
    Delta = Delta / WHEEL_DELTA
    With oContainer.txtNum
        .Text = Val(.Text) + Delta
        .SelStart = 0
        .SelLength = Len(.Text)
    End With
End Sub

本文參考：https://www.0xaa55.com/thread-1635-1-1.html

---

版權聲明：本文爲博主原創文章，如需轉載，請給出：
原文鏈接：https://blog.csdn.net/qq_35844043/article/details/103514150