mousewheel.bas

一个商业软件的源码

Attribute VB_Name = "Module1"
 Option Explicit
  Public ck As Form
  Public dt As Object
  Public ad As Adodc
  Public dts As Long
  Public tjbt As String
  Public Type POINTL
    
          X   As Long
    
          Y   As Long
    
  End Type
    
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 SystemParametersInfo Lib "USER32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
    
  Private Declare Function ScreenToClient Lib "USER32" (ByVal hwnd As Long, xyPoint As POINTL) As Long
    
  Public Const GWL_WNDPROC = -4
    
  Public Const SPI_GETWHEELSCROLLLINES = 104
    
  Public Const WM_MOUSEWHEEL = &H20A
    
  Public WHEEL_SCROLL_LINES     As Long
    
  Global lpPrevWndProc     As Long
  Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_SHOWNORMAL = 1


    
  Public Sub Hook(ByVal hwnd As Long)

  lpPrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
    
          '获取"控制面板"中的滚动行数值
    
  Call SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, WHEEL_SCROLL_LINES, 0)
    
          If WHEEL_SCROLL_LINES > dts Then
    
  WHEEL_SCROLL_LINES = dts
    
          End If
        
      
  
  End Sub
    
  Public Sub UnHook(ByVal hwnd As Long)
    
  Dim lngReturnValue     As Long
    
  lngReturnValue = SetWindowLong(hwnd, GWL_WNDPROC, lpPrevWndProc)
    
  End Sub
    
 Private 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, wKeys       As Integer
    
                          wzDelta = HIWORD(wParam)
    
                          wKeys = LOWORD(wParam)
    
                          pt.X = LOWORD(lParam)
    
                          pt.Y = HIWORD(lParam)
    
                          '将屏幕坐标转换为Form1.窗口坐标
    
                          ScreenToClient ck.hwnd, pt
    
                          With dt
    
  '判断坐标是否在Form1.grdDataGrid窗口内
    
  If pt.X > .Left / Screen.TwipsPerPixelX And pt.X < (.Left + .Width) / Screen.TwipsPerPixelX And pt.Y > .Top / Screen.TwipsPerPixelY And pt.Y < (.Top + .Height) / Screen.TwipsPerPixelY Then
    
  '滚动明细数据库
    
  
    
                                          With ad.Recordset
                                          If .RecordCount <> 0 Then
    
                                                  If Sgn(wzDelta) = 1 Then
    
                                                          
                                                          If .BOF = False Then
    
                                                                  .MovePrevious
                                                                  End If
    
                                                                  If .BOF = True Then
    
                                                                         .MoveFirst
    
                                                                  End If
    
    
                                                  Else
    
                                                          If .EOF = False Then
    
                                                                  .MoveNext
                                                                  
                                                                  End If
    
                                                                  If .EOF = True Then
    
                                                                         .MoveLast
    
                                                          End If
    
                                                  End If
                                             End If
                                          End With
    
                                  End If
    
                          End With
    
                  Case Else
    
  WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
    
          End Select
    
  End Function
    
  Public Function HIWORD(LongIn As Long) As Integer
    
        '   取出32位值的高16位
    
        HIWORD = (LongIn And &HFFFF0000) \ &H10000
    
  End Function
    
  Public Function LOWORD(LongIn As Long) As Integer
    
          '   取出32位值的低16位
    
              LOWORD = LongIn And &HFFFF&
    
  End Function