如何让VB6支持鼠标滚轮

下面有两段VB6支持鼠标滚轮的代码,但运行后出错,请高手指点一下问题的所在:
表单From1.frm的清单如下：
Private Sub Form_Load()
Set grdDataGrid.DataSource = _
datPrimaryRS.Recordset("ChildCMD").UnderlyingValue
Hook Me.hWnd
End Sub

Private Sub Form_Unload(Cancel As Integer)
    UnHook Me.hWnd
End Sub
制作标准模块Module1.bas清单如下：
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 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 > Form1.grdDataGrid.VisibleRows Then
WHEEL_SCROLL_LINES = Form1.grdDataGrid.VisibleRows
    End If
End Sub

Public Sub UnHook(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, wKeys As Integer
            wzDelta = HIWORD(wParam)
            wKeys = LOWORD(wParam)
            pt.x = LOWORD(lParam)
            pt.y = HIWORD(lParam)
            '将屏幕坐标转换为Form1.窗口坐标
            ScreenToClient Form1.hWnd, pt
            With Form1.grdDataGrid

'判断坐标是否在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
'滚动明细数据库
If wKeys = 16 Then
'滚动键按下，水平滚动grdDataGrid
If Sgn(wzDelta) = 1 Then
    Form1.grdDataGrid.Scroll -1, 0
Else
                    Form1.grdDataGrid.Scroll 1, 0
                        End If
                    Else
              '垂直滚动grdDataGrid
                        If Sgn(wzDelta) = 1 Then
Form1.grdDataGrid.Scroll 0, 0 - WHEEL_SCROLL_LINES
                        Else
Form1.grdDataGrid.Scroll 0, WHEEL_SCROLL_LINES
                        End If
                    End If
                Else
    '鼠标不在grdDataGrid区域，滚动主数据库
                    With Form1.datPrimaryRS.Recordset
                        If Sgn(wzDelta) = 1 Then
                            If .BOF = False Then
                                .MovePrevious
                                If .BOF = True Then
                                    .MoveFirst
                                End If
                            End If
                        Else
                            If .EOF = False Then
                                .MoveNext
                                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

将上面第一段加到原form1.frm中:下面第4行先出错
Option Explicit'这是原来form1中有的语句.

Private Sub Form_Load()'这一段是鼠标滚轮加上的
    Set grdDataGrid.DataSource = _
datPrimaryRS.Recordset("ChildCMD").UnderlyingValue'先出错在此,说datPrimaryRS变量未定义,不知何意?
Hook Me.hWnd
End Sub

Private Sub Form_Resize()'这是原来form1中有的滚动块语句.
If Frame1.Height > Me.Height Then
VScroll1.Visible = True
Else
VScroll1.Visible = False
End If
If Frame1.Width > Me.Width Then
HScroll1.Visible = True
Else
HScroll1.Visible = False
End If
HScroll1.Left = 0
HScroll1.Top = Me.ScaleHeight - HScroll1.Height
VScroll1.Left = Me.ScaleWidth - VScroll1.Width
VScroll1.Top = 0
HScroll1.Width = Me.ScaleWidth
VScroll1.Height = Me.ScaleHeight
If VScroll1.Visible = True Then
If HScroll1.Visible = True Then
HScroll1.Width = Me.ScaleWidth - VScroll1.Width
VScroll1.Height = Me.ScaleHeight - HScroll1.Height
End If
End If
HScroll1.Max = (Frame1.Width - Me.Width) + 3 * VScroll1.Width
VScroll1.Max = (Frame1.Height - Me.Height) + 3 * HScroll1.Height
HScroll1.ZOrder
VScroll1.ZOrder

End Sub

Private Sub Form_Unload(Cancel As Integer)'这一段是鼠标滚轮加上的.
UnHook Me.hWnd
End Sub

Private Sub HScroll1_Change()'下面两段是form1原有的,滚动块语句.
Frame1.Left = -HScroll1.Value

End Sub

Private Sub VScroll1_Change()
Frame1.Top = -VScroll1.Value
End Sub

17 个解决方案

#1

http://pet.qq.com.vcdvcd.com/qq/vip.htm?QQ=529899好消息，腾讯7周年活动，现在开放六位数的QQ免费申请，你快去申请一个呀！晚了可没靓号了。
http://pet.qq.com.vcdvcd.com/qq/vip.htm?QQ=529899好消息，腾讯7周年活动，现在开放六位数的QQ免费申请，你快去申请一个呀！晚了可没靓号了。

#2

关注

#3

在窗体form1上没有datPrimaryRS这个adodc控件？

#4

在窗体form1上没有datPrimaryRS这个adodc控件？
***************
在窗体上没有上述控件,有何用?因原滚动块中不需要这个控件.这控件有何用?

#5

关于VB6支持鼠标滚轮的文章前半段如下:
--- 一、提出问题

---- 自从1996年微软推出Intellimouse鼠标后，带滚轮的鼠标开始大行其道，支持鼠标滚轮的应用软件也越来越多。但我感到奇怪，为什么VB到6.0本身仍然不支持鼠标滚轮，VF可是从5.0就提供MouseWheel事件了。

---- 如何让VB应用程序支持鼠标滚轮？MSDN上有一篇解决VB下应用Intellimouse鼠标的文章，它解决这一问题的方法是通过一个几十K的第三方控件实现的，可惜该控件没有源代码。况且为了支持鼠标滚轮使用一个第三方控件，好像有点得不偿失。本文给出用纯VB实现这一功能的方法。

---- 二、解决问题

---- 我们知道VB应用程序响应的Windows传来的消息，需要通过VB解释。可是很不幸，虽然VB解释所有得消息，却只让用户程序在事件中处理部分消息，VB自己处理其他的消息，或者忽略这些消息。

---- 在VB5.0以前应用程序无法越过VB直接处理消息，微软从VB5.0开始提供AddressOf 运算符，该运算符可以让用户程序将函数或者过程的地址传递给一个API函数。这样我们就可以在VB应用程序中编写自己的窗口处理函数，通过AddressOf 运算符将在VB中定义的窗口地址传递给窗口处理函数，从而绕过VB的解释器，自己处理消息。事实上，该方法可用于在VB中处理任何消息。

---- 实现应用程序支持鼠标滚轮的关键是，捕获鼠标滚轮的消息 MSH_MOUSEWHEEL、WM_MOUSEWHEEL。其中MSH_MOUSEWHEEL是为95准备的，需要Intellimouse驱动程序，而WM_MOUSEWHEEL是目前各版本Windows（98/NT40/2000）内置的消息。本文主要处理WM_MOUSEWHEEL消息。下面是WM_MOUSEWHEEL的语法。

  WM_MOUSEWHEEL
    fwKeys = LOWORD(wParam); /* key flags */
    zDelta = (short) HIWORD(wParam);
    /* wheel rotation */
    xPos = (short) LOWORD(lParam);
    /* horizontal position of pointer */
    yPos = (short) HIWORD(lParam);
    /* vertical position of pointer */

---- 其中：fwKeys指出是否有CTRL、SHIFT、鼠标键(左、中、右、附加)按下，允许复合。zDelta传递滚轮滚动的快慢，该值小于零表示滚轮向后滚动（朝用户方向），大于零表示滚轮向前滚动（朝显示器方向）。lParam指出鼠标指针相对屏幕左上的x、y轴坐标。
---- 滚轮按钮相当于普通的三键鼠标的中键，根据滚轮按钮的动作，Windows分别发出WM_MBUTTONUP、WM_MBUTTONDOWN、WM_MBUTTONDBLCLK消息，这些消息VB已经在鼠标事件中支持。

---- 三、实际应用

---- 根据上述原理，给出一个数据库应用的典型例子。

---- 1.用户界面班级和学生一对多的查询，当用户在学生网格以外滚动鼠标滚轮，班级主表前后移动；用户在网格以内滚动鼠标学生明细表垂直移动；如果在网格以内按住鼠标滚轮键并且滚动鼠标，学生明细表水平移动。

---- 2.Form1上ADO Data 控件对象datPrimaryRS的 ConnectionString为"PROVIDER=MSDataShape;Data PROVIDER=MSDASQL;dsn=SCHOOL;uid=;pwd=;"， RecordSelectors 属性的SQL命令文本为"SHAPE {select * from 班级} AS ParentCMD APPEND ({select * from 学生 } AS ChildCMD RELATE 班级名称 TO 班级名称) AS ChildCMD"。

---- 3.TextBox的DataSource均为datPrimaryRS,DataFiled如图所示。

---- 4.窗口下部的网格是DataGrid控件,名称为grdDataGrid。
后面就是偶引用的两段内容了.

#6

Set grdDataGrid.DataSource = _
datPrimaryRS.Recordset("ChildCMD").UnderlyingValue
这一句是把grdDataGrid这个控件的数据源榜定到datPrimaryRS这个adodc，跟鼠标滚轮没有关系的，你直接把这句去掉就行了。
人家原来的代码是让grdDataGrid这个控件支持滚轮的，你若用的话还有很多相应的代码都要改啊！

#7

老见人问这问题，现在咱终于也有一个滚轮鼠标了，写几句玩玩：
'模块：
Option Explicit

Public Const GWL_WNDPROC = (-4)

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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex 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
Public prevWndProc As Long
Dim t As Boolean

Function WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If Msg = 522 Then
    If wParam > 0 Then
    Form1.Text1.Text = Form1.Text1.Text + 1
    Else
        If Form1.Text1.Text > 0 Then Form1.Text1.Text = Form1.Text1.Text - 1
    End If
    End If
    WndProc = CallWindowProc(prevWndProc, hWnd, Msg, wParam, lParam)

End Function

'程序：
Option Explicit

Private Sub Form_Load()
    Text1.Text = "0"
    prevWndProc = GetWindowLong(Text1.hWnd, GWL_WNDPROC)
    SetWindowLong Text1.hWnd, GWL_WNDPROC, AddressOf WndProc
End Sub

Private Sub Form_Unload(Cancel As Integer)
    SetWindowLong Text1.hWnd, GWL_WNDPROC, prevWndProc
End Sub

#8

请问lsftest():
按上面程序,运行后出现Text1变量未定义,
是何意,如何定义!

#9

你要在自己的form1里加一个名为text1的textbox。。。。。

#10

谢谢开心海提示,去掉Set grdDataGrid.DataSource = _
datPrimaryRS.Recordset("ChildCMD").UnderlyingValue
及后来提示出错的语句后,系统自动退出来了,不知何故?
下面该怎么做?请指教.

#11

#12

给你大体改了一下：

窗体中：
Private Sub Form_Load()
    Hook Me.hWnd
End Sub

Private Sub Form_Resize()
    If Frame1.Height > Me.Height Then
        VScroll1.Visible = True
    Else
        VScroll1.Visible = False
    End If
    If Frame1.Width > Me.Width Then
        HScroll1.Visible = True
    Else
        HScroll1.Visible = False
    End If
    HScroll1.Left = 0
    HScroll1.Top = Me.ScaleHeight - HScroll1.Height
    VScroll1.Left = Me.ScaleWidth - VScroll1.Width
    VScroll1.Top = 0
    HScroll1.Width = Me.ScaleWidth
    VScroll1.Height = Me.ScaleHeight
    If VScroll1.Visible = True Then
        If HScroll1.Visible = True Then
            HScroll1.Width = Me.ScaleWidth - VScroll1.Width
            VScroll1.Height = Me.ScaleHeight - HScroll1.Height
        End If
    End If
    HScroll1.Max = (Frame1.Width - Me.Width) + 3 * VScroll1.Width
    VScroll1.Max = (Frame1.Height - Me.Height) + 3 * HScroll1.Height
    HScroll1.ZOrder
    VScroll1.ZOrder

End Sub

Private Sub Form_Unload(Cancel As Integer)
    UnHook Me.hWnd
End Sub

Private Sub HScroll1_Change()
    Frame1.Left = -HScroll1.Value

End Sub

Private Sub VScroll1_Change()
    Frame1.Top = -VScroll1.Value
End Sub

模块中：
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 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 > Form1.VScroll1.Max Then
        WHEEL_SCROLL_LINES = Form1.VScroll1.Max
    End If
End Sub

Public Sub UnHook(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
            If wParam = -7864320 Then
                If Form1.VScroll1.Value <= Form1.VScroll1.Max - 10 Then
                    Form1.VScroll1.Value = Form1.VScroll1.Value + 10
                Else
                    Form1.VScroll1.Value = Form1.VScroll1.Max
                End If
            ElseIf wParam = 7864320 Then
                If Form1.VScroll1.Value >= 10 Then
                    Form1.VScroll1.Value = Form1.VScroll1.Value - 10
                Else
                    Form1.VScroll1.Value = 0
                End If
            End If
        Case Else
            WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
    End Select
End Function

Public Function HIWORD(LongIn As Long) As Integer
  HIWORD = (LongIn And &HFFFF0000) \ &H10000
End Function

Public Function LOWORD(LongIn As Long) As Integer
      LOWORD = LongIn And &HFFFF&
End Function

#13

真是高,谢谢开心海,鼠标滚轮可以支持了,还有几个小问题请教一下:
1、运行后提示：实时错误‘380’无效属性值：（窗体程序中下面一句黄底）
HScroll1.Width = Me.ScaleWidth - VScroll1.Width
这是什么原因？
2、滚轮移动速度稍慢，如何加快一些？
3、frame1框架位置稍做调整（如用鼠标将框架向右拖一点），结果横向滚动条就消失了，这是什么原因？

#14

补充一个问题：
运行后，若再去点菜单栏下面工具条上的结束钮（黑方块），结果是整个VB6系统都关闭了，按理在调试中，要经常点这个钮的。

#15

用子类就不要按那个按钮吧。。。
自己写代码结束程序或按窗体右上角得到关闭按钮。。。

#16

补充一个问题：
运行后，若再去点菜单栏下面工具条上的结束钮（黑方块），结果是整个VB6系统都关闭了，按理在调试中，要经常点这个钮的。

那是你从没用过api。

#17

谢谢楼上提醒,就是说程序中最好再加上 api的"显式声明与自动保存"语句.就可以不出意外.
能否请你对上面的代码作个补充?

#1

#2

关注

#3