Duda textbox y rueda de raton

[Nodoka]

Buenas?

Tengo una duda, no se si si hay alguna forma de hacerlo?

Pongo en situación,  un formulario con textbox grande con la propiedad multilinea  nada mas inicializarse se carga con un enorme texto desde una única celda de mi hoja de excel apareciendo la barra de desplazamiento en el textbox,  y para desplazarse debes seleccionar esa barra y mover el rato arriba o abajo para ver todo el contenido.

¿Hay alguna forma de qeu pille el desplazamiento con la rueda del ratón ? con los listbox y los combobox no tengo problemas para que al rueda del raton se desplace pero con el recuadro del textbox no consigo que la barra se mueva?

[DiegoPC]

A mi nunca me ha funcionado el "Mouse Wheel" en textboxes, Listboxes y comboboxes. Nada de nada

[Nodoka]

Hace 1 hora, DiegoPC dijo:

A mi nunca me ha funcionado el "Mouse Wheel" en textboxes, Listboxes y comboboxes. Nada de nada

Yo tengo Excel 2016el de  64bits

Y uso este código

Creas un modulo y metes este código

Option Explicit

Type POINTAPI
    x As Long
    y As Long
End Type

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type

#If VBA7 Then
    #If Win64 Then
        Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
    #Else
        Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If
    Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As LongPtr
    Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
    Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Dim hwnd As LongPtr, lMouseHook As LongPtr
#Else
    Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function GetActiveWindow Lib "user32" () As Long
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
    Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Dim hwnd As Long, lMouseHook As Long
#End If

Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Const HC_ACTION = 0
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
Const MK_LBUTTON = &H1
Const SM_CXVSCROLL = 2


Sub SetComboBoxHook(ByVal Control As Object)
    Dim tpt As POINTAPI
    Dim sBuffer As String
    Dim lRet As Long
    
    If lMouseHook = 0 Then
        GetCursorPos tpt
        #If VBA7 And Win64 Then
            Dim lPt As LongPtr
            CopyMemory lPt, tpt, LenB(tpt)
            hwnd = WindowFromPoint(lPt)
        #Else
            hwnd = WindowFromPoint(tpt.x, tpt.y)
        #End If
        sBuffer = Space(256)
        lRet = GetClassName(GetParent(hwnd), sBuffer, 256)
        If InStr(Left(sBuffer, lRet), "MdcPopup") Then
            SetFocus hwnd
            #If VBA7 Then
                lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.HinstancePtr, 0)
            #Else
                lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.Hinstance, 0)
            #End If
        End If
    End If
End Sub

Sub RemoveComboBoxHook()
    UnhookWindowsHookEx lMouseHook: lMouseHook = 0
End Sub


#If VBA7 Then
    Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, lParam As MSLLHOOKSTRUCT) As LongPtr
#Else
    Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As Long
#End If

    Dim sBuffer As String
    Dim lRet As Long
    Dim tRect As RECT
        
    sBuffer = Space(256)
    lRet = GetClassName(GetActiveWindow, sBuffer, 256)
    If Left(sBuffer, lRet) = "wndclass_desked_gsk" Then Call RemoveComboBoxHook
    If IsWindow(hwnd) = 0 Then Call RemoveComboBoxHook
    
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            #If VBA7 And Win64 Then
                Dim lPt As LongPtr
                Dim Low As Integer, High As Integer
                Dim lParm As LongPtr
                CopyMemory lPt, lParam.pt, LenB(lPt)
                If WindowFromPoint(lPt) = hwnd Then
            #Else
                Dim Low As Integer, High As Integer
                Dim lParm As Long
                If WindowFromPoint(lParam.pt.x, lParam.pt.y) = hwnd Then
            #End If
                    GetClientRect hwnd, tRect
                    If lParam.mouseData > 0 Then
                        Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
                        High = tRect.Top + ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
                        lParm = MakeDWord(Low, High)
                    Else
                        Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
                        High = tRect.Bottom - ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
                        lParm = MakeDWord(Low, High)
                    End If
                    PostMessage hwnd, WM_LBUTTONDOWN, MK_LBUTTON, lParm
                    PostMessage hwnd, WM_LBUTTONUP, MK_LBUTTON, lParm
            End If
        End If
    End If
    
    MouseProc = CallNextHookEx(lMouseHook, nCode, wParam, ByVal lParam)
End Function


Private Function MakeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long
    MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)
End Function

y ya luego en el userform  metes este código llamando a cada uno de tus listbox o combobox en el que quieras usar el desplazamiento por la rueda del ratón

Private Sub ComboBox_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Call SetComboBoxHook(ComboBox)
End Sub

Private Sub ComboBox_LostFocus()
    Call RemoveComboBoxHook
End Sub

Private Sub ComboBox_Change()
    'change event not affected by the hook.
End Sub

 

[Abraham Valencia]

Hola

Hasta donde recuerdo la barra de desplazamiento vertical de los TextBox no puede ser controlada por la rueda del ratón, ni siquiera usando funciones de la API de Windows.

Saludos