mousewheel.bas

来自「电话本信息 基本上实现电话功能 自己下载侃侃吧」· BAS 代码 · 共 79 行

Attribute VB_Name = "MOUSEWHEEL"

Private Type POINTL
  X As Long
  Y As Long
End Type



Private Const GWL_WNDPROC = -4
'Private Const SPI_GETWHEELSCROLLLINES = 104
Private Const WM_MOUSEWHEEL = &H20A
Private Const WHEEL_HORIZONTAL = 16
Private Const WHEEL_PERPENDICULAR = 32
'Public WHEEL_SCROLL_LINES As Long


Private lpPrevWndProc 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 Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, xyPoint As POINTL) As Long


Public Sub Hook_MOUSEWHEEL(ByVal HookFormA As Form)
  Dim hwnd As Long

  Set HookForm = HookFormA
  hwnd = HookForm.hwnd
  lpPrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub UnHook_MOUSEWHEEL(ByVal hwnd As Long)
  Dim lngReturnValue As Long
  lngReturnValue = SetWindowLong(hwnd, GWL_WNDPROC, lpPrevWndProc)
End Sub

Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim PT As POINTL
  Select Case uMsg
    Case WM_MOUSEWHEEL
      Dim wzDelta, Button As Integer
      
      wzDelta = HIWORD(wParam)
      Button = LOWORD(wParam)
      PT.X = LOWORD(lParam)
      PT.Y = HIWORD(lParam)
      '将屏幕坐标转换为HookForm.窗口坐标
      ScreenToClient HookForm.hwnd, PT
      With HookForm
      '判断坐标是否在HookForm窗口内
        If PT.X > 0 And PT.X < .Width And PT.Y > 0 And PT.Y < .Height Then
          '调用HookForm内的mForm_MouseUP过程
          If Button = 16 Then
            '滚动键按下，水平滚动
            Button = WHEEL_HORIZONTAL
          Else
            '垂直滚动
            Button = WHEEL_PERPENDICULAR
          End If
          HookForm.fMouseWheeL Button, Sgn(wzDelta) = 1
        End If
      End With
    Case Else
      WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
  End Select
End Function

Private Function HIWORD(LongIn As Long) As Integer
' 取出32位值的高16位
    HIWORD = (LongIn And &HFFFF0000) \ &H10000
End Function

Private Function LOWORD(LongIn As Long) As Integer
' 取出32位值的低16位
    LOWORD = LongIn And &HFFFF&
End Function