No actua la rueda del raton en un formulario

En un formulario en la que tengo un campo de texto en formato lago me aparecen las barras de desplazamiento correctamente pero no consigo que a traves de la rueda del raton sea desplazada la pantalla.

¿Qué he de hacer para que actue esta funcion?.

1 respuesta

Respuesta
2

Te indico lo que tienes que hacer, pero ten en cuenta que mi aportación, en este caso, es prácticamente nula, pues simplemente he hecho una búsqueda y he cogido retazos de código de aquí y de allá. El código que te indicaré tiene los nombres de los autores en forma de comentarios, así que rogaría que si alguien utiliza el código mantenga esos comentarios. Thxs!

1.- Créate un módulo stándar y en él escribes el siguiente código:

Public Const WM_VSCROLL = &H115
Public Const WM_HSCROLL = &H114
Public Const SB_LINEUP = 0
Public Const SB_LINEDOWN = 1
Public Const SB_PAGEUP = 2
Public Const SB_PAGEDOWN = 3
Public Declare Function SendMessage Lib "User32" _
   Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
   ByVal wParam As Long, lParam As Any) As Long
' Used in fhWnd() to get a handle on the text box used in mouse wheel code.
Public Declare Function apiGetFocus Lib "User32" _
        Alias "GetFocus" _
         () As Long
Public Function fhWnd(ctl As Control) As Long
' fhWnd() was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
    On Error Resume Next
    ctl.SetFocus
    If Err Then
        fhWnd = 0
    Else
        fhWnd = apiGetFocus
    End If
    On Error GoTo 0
End Function

2.- En tu formulario, en el evento "Al mover rueda del mouse", genera este código:

Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long)
' This procedure runs when the mouse wheel is used.
' Copyright © 2014 Extra Mile Data, www.extramiledata.com.
' For questions or issues, please contact [email protected].
' Use (at your own risk) and modify freely as long as proper credit is given.
' Proper credit includes mentioning the example by eggieman at
' http://www.access-programmers.co.uk/forums/showthread.php?t=195679
' and the fhWnd() function by Dev Ashish at
' http://access.mvps.org/access/api/api0027.htm.
On Error GoTo Err_Handler
    Dim intLinesToScroll As Integer
    Dim hwndActiveControl As Long
    ' Let the mouse wheel scroll in text boxes.
    If ActiveControl.Properties.Item("ControlType") = 109 Then
        hwndActiveControl = fhWnd(Screen.ActiveControl)
        If Count < 0 Then
            For intLinesToScroll = 1 To -1 * Count
                SendMessage hwndActiveControl, WM_VSCROLL, SB_LINEUP, 0
            Next
        Else
            For intLinesToScroll = 1 To Count
                SendMessage hwndActiveControl, WM_VSCROLL, SB_LINEDOWN, 0
            Next
        End If
    End If
Exit_Proc:
    On Error Resume Next
    Exit Sub
Err_Handler:
    MsgBox Err.Number & " " & Err.Description, vbCritical, _
        "Form_MouseWheel()"
    Resume Exit_Proc
End Sub

Y listos: cuando sitúes el foco en el control deberías poder utilizar la rueda del mouse para desplazarte.

Simplemente tener en cuenta que el módulo hace llamadas a API's de sistemas de 32 bits. Si diera errores por tener un sistema de 64 bits se deberían adaptar esas funciones de API's

Saludos,

Neckkito

http://bit.ly/neckkito /// http://bit.ly/ForoNkSv

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas