[Solucionado] Evento en La "Ruedita" del Raton

[agus0]

Hola que tal Foro...

Bueno hoy se me planteo una duda que no logro resolver

alguien tiene idea como podría hacer para darle un evento a la "Ruedita del Mause"



Es decir hacer por ejemplo

Código [Seleccionar] Expandir

Private Sub Form_MouseWheel(Sentido As Integer)
   If Sentido = 0 Then
       MsgBox "Rueda Girada hacia Arriba"
   Else
       MsgBox "Rueda Girada hacia Abajo"
   End If
End Sub


Gracias!!

[LeandroA]

hola Agrega un modulo clase con el nombre "ClsMouseWheel"

dentro de este modulo

Código (vb) [Seleccionar] Expandir

]
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

Código (vb) [Seleccionar] Expandir


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.

[agus0]

 

Lea La verdad Siempre tenes las respuestas a mis preguntas... Como Todos en este foro =)


G R A C I A S

[cobein]

Molesto mode

faltan los saltos de linea con system metrics

[Dessa]

Una pregunta, si fuera con Hook, estaria bien asi ? ... cual serian las ventajas y las desventajas ?, Gracias por anticipado.

FORM

Código [Seleccionar] Expandir



Option Explicit

Private Sub Form_Load()
   Me.AutoRedraw = True
   StartHook Me.hwnd
End Sub

Private Sub Form_Unload(Cancel As Integer)
   StopHook Me.hwnd
End Sub




MODULO

Código [Seleccionar] Expandir



Option Explicit

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 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 Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL As Long = &H20A

Dim hHook As Long

Public Sub StartHook(hwnd As Long)
   hHook = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub StopHook(hwnd As Long)
   SetWindowLong hwnd, GWL_WNDPROC, hHook
End Sub

Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 WindowProc = CallWindowProc(hHook, hwnd, uMsg, wParam, lParam)
 If uMsg = WM_MOUSEWHEEL Then
   If wParam > 0 Then
     Form1.Print "ARRIBA"
   Else
     Form1.Print "ABAJO"
   End If
 End If
End Function