VB6对滚轮的支持

Option   Explicit
Public  Type POINTL
X  As   Long
Y  As   Long
End  Type
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
Declare  Function  SetWindowLong Lib  " USER32 "  Alias  " SetWindowLongA "  (ByVal hWnd  As   Long , ByVal nIndex  As   Long , ByVal dwNewLong  As   Long )  As   Long
Declare  Function  SystemParametersInfo Lib  " USER32 "  Alias  " SystemParametersInfoA "  (ByVal uAction  As   Long , ByVal uParam  As   Long , lpvParam  As  Any, ByVal fuWinIni  As   Long )  As   Long
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
Public  sngX  As   Single , sngY  As   Single     ' 鼠标坐标
Public  intShift  As   Integer                ' 鼠标按键
Public  bWay  As   Boolean                    ' 鼠标方向
Public  bMouseFlag  As   Boolean              ' 鼠标事件激活标志
 
' *************************************************************************
' **函 数 名：Hook
' **输    入：ByVal hWnd(Long) - 窗口句柄
' **输    出：无
' **功能描述：安装鼠标钩子
' *************************************************************************
Public   Sub  Hook(ByVal hWnd  As   Long )
    lpPrevWndProc  =  SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
     ' 获取"控制面板"中的滚动行数值
     Call  SystemParametersInfo(SPI_GETWHEELSCROLLLINES,  0 , WHEEL_SCROLL_LINES,  0 )
End Sub
 
' *************************************************************************
' **函 数 名：UnHook
' **输    入：ByVal hWnd(Long) - 窗口句柄
' **输    出：无
' **功能描述：卸载鼠标钩子
' *************************************************************************
Public   Sub  UnHook(ByVal hWnd  As   Long )
     Dim  lngReturnValue  As   Long
    lngReturnValue  =  SetWindowLong(hWnd, GWL_WNDPROC, lpPrevWndProc)
End Sub
 
' *************************************************************************
' **函 数 名：WindowProc
' **输    入：ByVal hw(Long)     - 窗口句柄
' **        ：ByVal uMsg(Long)   - 消息类型
' **        ：ByVal wParam(Long) -
' **        ：ByVal lParam(Long) -
' *************************************************************************
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传递滚轮滚动的快慢，该值小于零表示滚轮向后滚动（朝用户方向），
             ' 大于零表示滚轮向前滚动（朝显示器方向）
            wzDelta  =  HIWORD(wParam)
             
             ' wKeys指出是否有CTRL=8、SHIFT=4、鼠标键(左=2、中=16、右=2、附加)按下，允许复合
            wKeys  =  LOWORD(wParam)
             
             ' pt鼠标的坐标
            pt.X  =  LOWORD(lParam)
            pt.Y  =  HIWORD(lParam)
             
             ' --------------------------------------------------
              If  wzDelta  <   0   Then    ' 朝用户方向
                bWay  =   True
                 ' 在这里你自己处理－－－－－－－－－－－－－－－－－－
 
                main.Cmap.ZoomOut
                 ' MsgBox 0       '这行代码由我加入，使用时改为你自己的代码
              Else                   ' 朝显示器方向
                bWay  =   False
                main.Cmap.ZoomIn
                 ' MsgBox 1        '这行代码由我加入，使用时改为你自己的代码
              End   If
             ' --------------------------------------------------
             ' 将屏幕坐标转换为Form1.窗口坐标
             ScreenToClient hw, pt
             sngX  =  pt.X
             sngY  =  pt.Y
             intShift  =  wKeys
             
             bMouseFlag  =   True    ' 置滚动标志
         Case   Else
            WindowProc  =  CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
     End   Select
End Function
 
' *************************************************************************
' **函 数 名：HIWORD
' **输    入：LongIn(Long) - 32位值
' **输    出：(Integer) - 32位值的低16位
' **功能描述：取出32位值的高16位
' *************************************************************************
Public   Function  HIWORD(LongIn  As   Long )  As   Integer
    '  取出32位值的高16位
     HIWORD  =  (LongIn  And   & HFFFF0000)  \   & H10000
End Function
 
' *************************************************************************
' **函 数 名：LOWORD
' **输    入：LongIn(Long) - 32位值
' **输    出：(Integer) - 32位值的低16位
' **功能描述：取出32位值的低16位
' *************************************************************************
Public   Function  LOWORD(LongIn  As   Long )  As   Integer
    '  取出32位值的低16位
     LOWORD  =  LongIn  And   & HFFFF &
End Function