鼠标滚轮编程

1. 求VB鼠标滚轮的常量

很不幸，VB6诞生的时候，鼠标还没有滚轮呢，所以没有专门的代表滚轮的常量。这也解释了为什么VB6不支持鼠标滚轮的原因（包括编程环境、设计中的程序和编译后的可执行文件，都是不支持鼠标滚轮的），必须使用特殊手段才能有限实现滚轮效果。

2. 鼠标编程是不是可以一次连续释放技能

（1）是的，稍微中级和高级的游戏鼠标一般都有编程按键。

（2）以罗技鼠标为例，如下图，在对应的功能界面录入多键，设置好每个动作间的时间间隔 ，设置好后，在按下那一个编程按键后，就会自动执行录制好的那一系列动作：

3. 罗技鼠标滚轮编程

需要编写程序来控制，安装一个全局鼠标钩子，拦截鼠标滚轮消息，然后在回调函数里执行相应的操作!

4. vb鼠标滚轮问题

标滚轮能给系统的使用带来很大便利，如使用滚轮移动选择这项，但在VB中的一些常用控件（如：文件框、列表框等）中没有提供鼠标滚轮滚动选择的效果。现将自己写的鼠标滚轮特效实现代码分享给大家： 本例子就是一个对Win32 API的调用，达到对ListBox、PictureBox等的鼠标滚轮控制。首先，申明windows API调用，将其放在模块modWheel中，以供用户控件使用。原理很简单，通过鼠标滚轮可以对如下白色的横线进行控制，效果图如下：相关代码如下： 鼠标滚轮处理模块(modWheel)
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDest As Any, pSource As Any, ByVal ByteLen 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 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 SetProp Lib "user32" Alias "SetPropA" _
(ByVal hWnd As Long, ByVal lpString As String, _
ByVal hData As Long) As Long
Declare Function GetProp Lib "user32" Alias "GetPropA" _
(ByVal hWnd As Long, ByVal lpString As String) As Long
Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _
(ByVal hWnd As Long, ByVal lpString As String) As Long
Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Public Const WM_MOUSEWHEEL = &H20A
Public Const WM_MOUSELAST = &H20A
Public Const WHEEL_DELTA = 120
Public Function HIWORD(LongIn As Long) As Integer
HIWORD = (LongIn And &HFFFF0000) \ &H10000
End Function
Public Function MWheelProc(ByVal hWnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim OldProc As Long
Dim CtlWnd As Long
Dim CtlPtr As Long
Dim IntObj As Object
Dim MWObject As MWheel
CtlWnd = GetProp(hWnd, "WheelWnd")
CtlPtr = GetProp(CtlWnd, "WheelPtr")
OldProc = GetProp(CtlWnd, "OldWheelProc")
If wMsg = WM_MOUSEWHEEL Then
CopyMemory IntObj, CtlPtr, 4
Set MWObject = IntObj
MWObject.WndProc hWnd, wMsg, wParam, lParam
Set MWObject = Nothing
CopyMemory IntObj, 0&, 4
Exit Function
End If
MWheelProc = CallWindowProc(OldProc, hWnd, wMsg, wParam, lParam)
End Function
Public Sub Subclass(MWCtl As MWheel, ParentWnd As Long)
If GetProp(MWCtl.hWnd, "OldWheelProc") <> 0 Then
Exit Sub
End If
SetProp MWCtl.hWnd, "OldWheelProc", _
GetWindowLong(ParentWnd, GWL_WNDPROC)
SetProp MWCtl.hWnd, "WheelPtr", ObjPtr(MWCtl)
SetProp ParentWnd, "WheelWnd", MWCtl.hWnd
SetWindowLong ParentWnd, GWL_WNDPROC, AddressOf MWheelProc
End Sub
Public Sub UnSubclass(MWCtl As MWheel, ParentWnd As Long)
Dim OldProc As Long
OldProc = GetProp(MWCtl.hWnd, "OldWheelProc")
If OldProc = 0 Then Exit Sub
SetWindowLong ParentWnd, GWL_WNDPROC, OldProc
RemoveProp ParentWnd, "WheelWnd"
RemoveProp MWCtl.hWnd, "WheelPtr"
RemoveProp MWCtl.hWnd, "OldWheelProc"
End Sub
然后，定义用户控件MWheel，实现对相关控件鼠标滚轮事件的处理。用户控件（MWheel)代码
Option Explicit
Dim m_CapWnd As Long
Dim m_Subclassed As Boolean
Event WheelScroll(Shift As Integer, zDelta As Integer, _
X As Single, Y As Single)
Private Sub UserControl_Resize()
Size 32 * Screen.TwipsPerPixelX, 32 * Screen.TwipsPerPixelY
End Sub
Public Sub DisableWheel()
If m_CapWnd = 0 Then Exit Sub
If m_Subclassed = False Then Exit Sub
UnSubclass Me, m_CapWnd
m_Subclassed = False
End Sub
Public Sub EnableWheel()
If m_CapWnd = 0 Then Exit Sub
m_Subclassed = True
Subclass Me, m_CapWnd
End Sub
Friend Property Get hWnd() As Long
hWnd = UserControl.hWnd
End Property
Public Property Get hWndCapture() As Long
hWndCapture = m_CapWnd
End Property
Public Property Let hWndCapture(ByVal vNewValue As Long)
m_CapWnd = vNewValue
End Property
Friend Sub WndProc(ByVal hWnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Dim wShift As Integer
Dim wzDelta As Integer
Dim wX As Single, wY As Single
wzDelta = HIWORD(wParam)
wY = HIWORD(lParam)
RaiseEvent WheelScroll(wShift, wzDelta, wX, wY)
End Sub最后，就可以将定义的用户控件用在vb窗体编程中，实现对鼠标滚轮事件的监听和处理，测试主窗体如下：Option Explicit
Dim KAs As Long
Dim KA1 As Long
Dim KA2 As Long
Private Sub Picture1_Click()
MWheel1.hWndCapture = Picture1.hWnd
MWheel1.EnableWheel
End Sub
Private Sub List1_Click()
MWheel2.hWndCapture = List1.hWnd
MWheel2.EnableWheel
KA1 = List1.ListCount
End Sub
Private Sub File1_Click()
MWheel3.hWndCapture = File1.hWnd
MWheel3.EnableWheel
KA1 = File1.ListCount
End Sub
Private Sub MWheel2_WheelScroll(Shift As Integer, zDelta As Integer, X As Single, Y As Single)
If KAs > 0 Then
If zDelta = 120 Then
KAs = KAs - 1
List1.ListIndex = KAs
End If
End If
If KAs < KA1 - 1 Then
If zDelta = -120 Then
KAs = KAs + 1
List1.ListIndex = KAs
End If
End If
End Sub
Private Sub MWheel1_WheelScroll(Shift As Integer, zDelta As Integer, X As Single, Y As Single)
If zDelta = 120 Then
KA2 = KA2 - 5
Line1.Y1 = KA2
Line1.Y2 = KA2
End If
If zDelta = -120 Then
KA2 = KA2 + 5
Line1.Y1 = KA2
Line1.Y2 = KA2
End If
End Sub
Private Sub MWheel3_WheelScroll(Shift As Integer, zDelta As Integer, X As Single, Y As Single)

If KAs > 0 Then
If zDelta = 120 Then
KAs = KAs - 1
File1.ListIndex = KAs
End If
End If
If KAs < KA1 - 1 Then
If zDelta = -120 Then
KAs = KAs + 1
File1.ListIndex = KAs
End If
End If
End Sub</SPAN>

5. Delphi鼠标滚轮如何编程

我们使用的鼠标，很多都带有一个滚轮，方便用户的操作。但遗憾的是，平时编程多数只利用到鼠标的左、右两键，如果将滚轮操作功能也加进你的程序，定能使其增色不少。 当鼠标指针指向窗体中时，Delphi为滚轮滚动提供OnMouseWheel事件，我们可以对它进行相应的处理。本例中，在窗体内放置一标签Label1，用于显示滚轮滚动的效果。 implementation var i:integer; procere TForm1.FormCreate(Sender: TObject); begin i:=0; Label1.Caption:=inttostr(i); end; procere TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); begin if WheelDelta>0 then i:=i+1 else i:=i-1; //wheelDelta参数表示滚动一格的值，向上滚动为正数，向下滚动则为负数 Label1.Caption:=inttostr(i); end;

6. 如何用VB编程，来禁止电脑鼠标滚轮的使用谢谢！

截取鼠标滚轮消息及窗体消息
'窗体
Option Explicit

Private Const MOD_ALT As Long = &H1
Private Const MOD_CONTROL As Long = &H2
Private Const MOD_SHIFT As Long = &H4

Private Const GWL_WNDPROC = (-4)

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'注册/反注册热键
Private Declare Function RegisterHotKey Lib "user32.dll" (ByVal hWnd As Long, ByVal ID As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Private Declare Function UnregisterHotKey Lib "user32.dll" (ByVal hWnd As Long, ByVal ID As Long) As Long

Private Sub Form_Load()
Dim ret As Long
Print "关闭本实例一定要按下窗体上的关闭按钮关闭，否则会出现错误！"
'记录原来的 Window Procere 的位址
preProc = GetWindowLong(Me.hWnd, GWL_WNDPROC)
'设定form的 Window Procere 到 hProc
ret = SetWindowLong(Me.hWnd, GWL_WNDPROC, AddressOf hProc)
'注册热键，RegisterHotKey 的第三个参数为附加的功能键，不用时应设为 0
'注册热键为 Ctrl + F
Call RegisterHotKey(Me.hWnd, &HFFFFF, MOD_CONTROL, vbKeyF)
End Sub

Private Sub Form_Unload(Cancel As Integer)
'反注册热键
Call UnregisterHotKey(Me.hWnd, &HFFFFF)
'取消窗体消息的截取，而使之又只送往原来的 Window Procere
Call SetWindowLong(Me.hWnd, GWL_WNDPROC, preProc)
End Sub

'模块
Option Explicit

'Prodeced 2007 By TZWSOHO
'下面给出一小部分窗体消息的解释，想获取更多内容请参考微软的 MSDN
Private Const WM_GETMINMAXINFO As Long = &H24 '窗体移动或改变大小时激发的通告，可控制窗口能改变的大小
Private Const WM_MOUSEWHEEL As Long = &H20A '鼠标滚轮滚动通告
Private Const WM_DEVICECHANGE As Long = &H219 '设备插入通告，可用于检测当前是否有可移动磁盘插入
Private Const WM_HOTKEY As Long = &H312 '热键键入通告

Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public preProc As Long

Function hProc(ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case msg
Case WM_HOTKEY
'转成十六进制后的 lParam 首两位为对应热键的键代码，
'末两位是功能键的代码：1 = Alt, 2 = Ctrl, 4 = Shift
'其余值为代码的和，如：3 = Alt + Ctrl
Form1.Print Hex(lParam)
Form1.Print "用户按下热键！"
Case WM_MOUSEWHEEL '鼠标滚轮滚动，方向取决于 wParam 的符号
If Sgn(wParam) = -1 Then 'wParam 的符号为负，滚轮从左往右看为顺时针旋转
Form1.Print "滚轮向后滚"
ElseIf Sgn(wParam) = 1 Then 'wParam 的符号为正，滚轮从左往右看为逆时针旋转
Form1.Print "滚轮向前滚"
End If
End Select
hProc = CallWindowProc(preProc, hWnd, msg, wParam, lParam)
End Function

7. 请教：用vb编程如何实现用鼠标滚轮扩大和缩小窗体上的图片

添加一个模块，输入以下代码：

Public 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
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long

Public Const GWL_WNDPROC = -4&
Public Const WM_MOUSEWHEEL = &H20A

Public Type POINTAPI
x As Long
y As Long
End Type

Public OldWindowProc As Long
Public ohwnd As Long

Public Function NewWindowProc(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
Dim CurPoint As POINTAPI, hwndUnderCursor As Long
GetCursorPos CurPoint
hwndUnderCursor = WindowFromPoint(CurPoint.x, CurPoint.y)
If hwndUnderCursor = ohwnd Then
If wParam = -7864320 Then
If Form1.Picture1.Width < Form1.ScaleWidth Then Form1.Picture1.Width = Form1.Picture1.Width + 300
If Form1.Picture1.Height < Form1.ScaleHeight Then Form1.Picture1.Height = Form1.Picture1.Height + 240
ElseIf wParam = 7864320 Then
If Form1.Picture1.Width > 600 Then Form1.Picture1.Width = Form1.Picture1.Width - 300
If Form1.Picture1.Height > 480 Then Form1.Picture1.Height = Form1.Picture1.Height - 240
End If
End If
Else
NewWindowProc = CallWindowProc(OldWindowProc, hwnd, Msg, wParam, lParam)
End If
End Function

在Form1中放入一个Picture1控件，然后输入以下代码：

Private Sub Form_Load()
Picture1.AutoRedraw = True
Picture1.Picture = LoadPicture("e:\tmp\cd1.gif") '图片文件名，自己改
Picture1.Move 0, 0, 6000, 4800
ohwnd = Picture1.hwnd
OldWindowProc = GetWindowLong(Picture1.hwnd, GWL_WNDPROC)
Call SetWindowLong(Picture1.hwnd, GWL_WNDPROC, AddressOf NewWindowProc)
End Sub

Private Sub Picture1_Resize()
Picture1.PaintPicture Picture1.Picture, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight
End Sub