elhacker.net cabecera Bienvenido(a), Visitante. Por favor Ingresar o Registrarse
¿Perdiste tu email de activación?.

 

 


Tema destacado:


+  Foro de elhacker.net
|-+  Programación
| |-+  Programación General
| | |-+  .NET (C#, VB.NET, ASP)
| | | |-+  Programación Visual Basic (Moderadores: LeandroA, seba123neo)
| | | | |-+  [Solucionado] Evento en La "Ruedita" del Raton
0 Usuarios y 1 Visitante están viendo este tema.
Páginas: [1] Ir Abajo Respuesta Imprimir
Autor Tema: [Solucionado] Evento en La "Ruedita" del Raton  (Leído 2,867 veces)
agus0


Desconectado Desconectado

Mensajes: 360



Ver Perfil
[Solucionado] Evento en La "Ruedita" del Raton
« en: 6 Junio 2010, 04:48 am »

Hola que tal Foro...

Bueno hoy se me planteo una duda que no logro resolver :P

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



Es decir hacer por ejemplo

Código:
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!!


« Última modificación: 6 Junio 2010, 05:43 am por agus0 » En línea

LeandroA
Moderador
***
Desconectado Desconectado

Mensajes: 760


www.leandroascierto.com


Ver Perfil WWW
Re: [Ayuda] Evento en La "Ruedita" del Raton
« Respuesta #1 en: 6 Junio 2010, 05:16 am »

hola Agrega un modulo clase con el nombre "ClsMouseWheel"

dentro de este modulo


Código
  1. ]
  2. Option Explicit
  3. Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
  4. Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  5. 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
  6. Private Const GWL_WNDPROC As Long = -4
  7.  
  8. Private Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
  9. Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
  10.  
  11. 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
  12. Private Declare Function VirtualFree Lib "kernel32.dll" (ByRef lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
  13. Private Const MEM_COMMIT As Long = &H1000
  14. Private Const PAGE_EXECUTE_READWRITE As Long = &H40
  15. Private Const MEM_RELEASE As Long = &H8000&
  16.  
  17. Private Const WM_DESTROY As Long = &H2
  18. Private Const WM_MOUSEWHEEL As Long = &H20A
  19.  
  20.  
  21. Private pASMWrapper As Long
  22. Private PrevWndProc As Long
  23. Private hSubclassedWnd As Long
  24.  
  25. Public Event MOUSEWHEEL(ByVal wParam As Long)
  26.  
  27. Public Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  28.  
  29.    WindowProc = CallWindowProc(PrevWndProc, hwnd, Msg, wParam, lParam)
  30.  
  31.    If Msg = WM_MOUSEWHEEL Then
  32.        RaiseEvent MOUSEWHEEL(wParam)
  33.    End If
  34.  
  35.    If Msg = WM_DESTROY Then
  36.        Call StopSubclassing
  37.    End If
  38.  
  39. End Function
  40.  
  41. Public Function SetSubclassing(ByVal hwnd As Long) As Boolean
  42.  
  43.    'Setzt Subclassing, sofern nicht schon gesetzt
  44.  
  45.    If PrevWndProc = 0 Then
  46.        If pASMWrapper <> 0 Then
  47.  
  48.            PrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, pASMWrapper)
  49.  
  50.            If PrevWndProc <> 0 Then
  51.                hSubclassedWnd = hwnd
  52.                SetSubclassing = True
  53.            End If
  54.  
  55.        End If
  56.    End If
  57.  
  58. End Function
  59.  
  60. Public Function StopSubclassing() As Boolean
  61.  
  62.    'Stopt Subclassing, sofern gesetzt
  63.  
  64.    If hSubclassedWnd <> 0 Then
  65.        If PrevWndProc <> 0 Then
  66.  
  67.            Call SetWindowLong(hSubclassedWnd, GWL_WNDPROC, PrevWndProc)
  68.  
  69.            hSubclassedWnd = 0
  70.            PrevWndProc = 0
  71.  
  72.            StopSubclassing = True
  73.  
  74.        End If
  75.    End If
  76.  
  77. End Function
  78.  
  79. Private Sub Class_Initialize()
  80.  
  81.    Dim ASM(0 To 103) As Byte
  82.    Dim pVar As Long
  83.    Dim ThisClass As Long
  84.    Dim CallbackFunction As Long
  85.    Dim pVirtualFree
  86.    Dim i As Long
  87.    Dim sCode As String
  88.  
  89.    pASMWrapper = VirtualAlloc(ByVal 0&, 104, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
  90.    If pASMWrapper <> 0 Then
  91.  
  92.        ThisClass = ObjPtr(Me)
  93.        Call CopyMemory(pVar, ByVal ThisClass, 4)
  94.        Call CopyMemory(CallbackFunction, ByVal (pVar + 28), 4)
  95.        pVirtualFree = GetProcAddress(GetModuleHandle("kernel32.dll"), "VirtualFree")
  96.  
  97.        sCode = "90FF05000000006A0054FF742418FF742418FF742418FF7424186800000000B800000000FFD0FF0D00000000A10000000085C075" & _
  98.                "0458C21000A10000000085C0740458C2100058595858585868008000006A00680000000051B800000000FFE00000000000000000"
  99.  
  100.        For i = 0 To Len(sCode) - 1 Step 2
  101.            ASM(i / 2) = CByte("&h" & Mid$(sCode, i + 1, 2))
  102.        Next
  103.  
  104.        Call CopyMemory(ASM(3), pASMWrapper + 96, 4)
  105.        Call CopyMemory(ASM(40), pASMWrapper + 96, 4)
  106.        Call CopyMemory(ASM(58), pASMWrapper + 96, 4)
  107.        Call CopyMemory(ASM(45), pASMWrapper + 100, 4)
  108.        Call CopyMemory(ASM(84), pASMWrapper, 4)
  109.        Call CopyMemory(ASM(27), ThisClass, 4)
  110.        Call CopyMemory(ASM(32), CallbackFunction, 4)
  111.        Call CopyMemory(ASM(90), pVirtualFree, 4)
  112.        Call CopyMemory(ByVal pASMWrapper, ASM(0), 104)
  113.  
  114.    End If
  115.  
  116. End Sub
  117.  
  118. Private Sub Class_Terminate()
  119.  
  120.    If pASMWrapper <> 0 Then
  121.        Call StopSubclassing
  122.        Call CopyMemory(ByVal (pASMWrapper + 108), 1, 4)
  123.    End If
  124.  
  125. End Sub
  126.  

y en el formulario
Código
  1. Option Explicit
  2. Private WithEvents cRuedaRaton As ClsMouseWheel
  3.  
  4. Private Sub cRuedaRaton_MOUSEWHEEL(ByVal wParam As Long)
  5.    If wParam > 0 Then
  6.        MsgBox "Rueda Girada hacia Arriba"
  7.    Else
  8.        MsgBox "Rueda Girada hacia Abajo"
  9.    End If
  10. End Sub
  11.  
  12. Private Sub Form_Load()
  13.    Set cRuedaRaton = New ClsMouseWheel
  14.    cRuedaRaton.SetSubclassing Me.hwnd
  15. End Sub
  16.  
  17. Private Sub Form_Unload(Cancel As Integer)
  18.    cRuedaRaton.StopSubclassing
  19.    Set cRuedaRaton = Nothing
  20. End Sub
  21.  

Saludos.





En línea

agus0


Desconectado Desconectado

Mensajes: 360



Ver Perfil
Re: [Ayuda] Evento en La "Ruedita" del Raton
« Respuesta #2 en: 6 Junio 2010, 05:43 am »

 ;-) ;-) ;-) ;-) ;-)

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


G R A C I A S
En línea

cobein


Desconectado Desconectado

Mensajes: 759



Ver Perfil WWW
Re: [Solucionado] Evento en La "Ruedita" del Raton
« Respuesta #3 en: 6 Junio 2010, 07:05 am »

Molesto mode

faltan los saltos de linea con system metrics
En línea

http://www.advancevb.com.ar
Más Argentino que el morcipan
Aguante el Uvita tinto, Tigre, Ford y seba123neo
Karcrack es un capo.
Dessa


Desconectado Desconectado

Mensajes: 624



Ver Perfil
Re: [Solucionado] Evento en La "Ruedita" del Raton
« Respuesta #4 en: 6 Junio 2010, 15:35 pm »

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

FORM

Código:

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:

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



« Última modificación: 6 Junio 2010, 15:37 pm por Dessa » En línea

Adrian Desanti
Páginas: [1] Ir Arriba Respuesta Imprimir 

Ir a:  

WAP2 - Aviso Legal - Powered by SMF 1.1.21 | SMF © 2006-2008, Simple Machines