hola Agrega un modulo
clase con el nombre "ClsMouseWheel"
dentro de este modulo
]
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length 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 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
Private Const GWL_WNDPROC As Long = -4
Private Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function VirtualAlloc Lib "kernel32.dll" (ByRef lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32.dll" (ByRef lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Const MEM_COMMIT As Long = &H1000
Private Const PAGE_EXECUTE_READWRITE As Long = &H40
Private Const MEM_RELEASE As Long = &H8000&
Private Const WM_DESTROY As Long = &H2
Private Const WM_MOUSEWHEEL As Long = &H20A
Private pASMWrapper As Long
Private PrevWndProc As Long
Private hSubclassedWnd As Long
Public Event MOUSEWHEEL(ByVal wParam As Long)
Public Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WindowProc = CallWindowProc(PrevWndProc, hwnd, Msg, wParam, lParam)
If Msg = WM_MOUSEWHEEL Then
RaiseEvent MOUSEWHEEL(wParam)
End If
If Msg = WM_DESTROY Then
Call StopSubclassing
End If
End Function
Public Function SetSubclassing(ByVal hwnd As Long) As Boolean
'Setzt Subclassing, sofern nicht schon gesetzt
If PrevWndProc = 0 Then
If pASMWrapper <> 0 Then
PrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, pASMWrapper)
If PrevWndProc <> 0 Then
hSubclassedWnd = hwnd
SetSubclassing = True
End If
End If
End If
End Function
Public Function StopSubclassing() As Boolean
'Stopt Subclassing, sofern gesetzt
If hSubclassedWnd <> 0 Then
If PrevWndProc <> 0 Then
Call SetWindowLong(hSubclassedWnd, GWL_WNDPROC, PrevWndProc)
hSubclassedWnd = 0
PrevWndProc = 0
StopSubclassing = True
End If
End If
End Function
Private Sub Class_Initialize()
Dim ASM(0 To 103) As Byte
Dim pVar As Long
Dim ThisClass As Long
Dim CallbackFunction As Long
Dim pVirtualFree
Dim i As Long
Dim sCode As String
pASMWrapper = VirtualAlloc(ByVal 0&, 104, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
If pASMWrapper <> 0 Then
ThisClass = ObjPtr(Me)
Call CopyMemory(pVar, ByVal ThisClass, 4)
Call CopyMemory(CallbackFunction, ByVal (pVar + 28), 4)
pVirtualFree = GetProcAddress(GetModuleHandle("kernel32.dll"), "VirtualFree")
sCode = "90FF05000000006A0054FF742418FF742418FF742418FF7424186800000000B800000000FFD0FF0D00000000A10000000085C075" & _
"0458C21000A10000000085C0740458C2100058595858585868008000006A00680000000051B800000000FFE00000000000000000"
For i = 0 To Len(sCode) - 1 Step 2
ASM(i / 2) = CByte("&h" & Mid$(sCode, i + 1, 2))
Next
Call CopyMemory(ASM(3), pASMWrapper + 96, 4)
Call CopyMemory(ASM(40), pASMWrapper + 96, 4)
Call CopyMemory(ASM(58), pASMWrapper + 96, 4)
Call CopyMemory(ASM(45), pASMWrapper + 100, 4)
Call CopyMemory(ASM(84), pASMWrapper, 4)
Call CopyMemory(ASM(27), ThisClass, 4)
Call CopyMemory(ASM(32), CallbackFunction, 4)
Call CopyMemory(ASM(90), pVirtualFree, 4)
Call CopyMemory(ByVal pASMWrapper, ASM(0), 104)
End If
End Sub
Private Sub Class_Terminate()
If pASMWrapper <> 0 Then
Call StopSubclassing
Call CopyMemory(ByVal (pASMWrapper + 108), 1, 4)
End If
End Sub
y en el formulario
Option Explicit
Private WithEvents cRuedaRaton As ClsMouseWheel
Private Sub cRuedaRaton_MOUSEWHEEL(ByVal wParam As Long)
If wParam > 0 Then
MsgBox "Rueda Girada hacia Arriba"
Else
MsgBox "Rueda Girada hacia Abajo"
End If
End Sub
Private Sub Form_Load()
Set cRuedaRaton = New ClsMouseWheel
cRuedaRaton.SetSubclassing Me.hwnd
End Sub
Private Sub Form_Unload(Cancel As Integer)
cRuedaRaton.StopSubclassing
Set cRuedaRaton = Nothing
End Sub
Saludos.
Mostrar Mensajes
