Usar a roda do rato para fazer scroll numa listbox num Formulário- JJoão (03/2006)

Duvida colocada : "Aproveito a oportunidade para (se possível) me informar como faço para rolar com o mouse as linhas de um ListBox, pois só estou conseguindo isto com as teclas (seta para cima e seta para baixo), e após exaustiva pesquisa na ajuda do VBA e também nos sites sobre o assunto, nada encontrei sobre isto.."

Solução: Encontrei à uns tempos este código na Net, desconheco o seu autor, mas funciona, fiz-lhe umas pequenas alterações, usa a API do Windows de modo a interceptar certos eventos e aplicá-los à Listbox, neste caso, eventos associados ao rato sobre a listbox.
Existe a condição de o formulário ter de ser inicializado em VBModal e nâo VBModeless, se definir este ultimo o excel puderá bloquear.

Para o Teste:
- Construir um Userform com uma Listbox;
- Adicionar um modulo.
- Colocar no modulo :

Option Explicit
 
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 FindWindow Lib "user32" _
                  Alias "FindWindowA" (ByVal lpClassName As String, _
                                       ByVal lpWindowName As String) 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 = -4
Private Const WM_MOUSEWHEEL = &H20A

Dim colForm As New Collection
Dim colFormHdl As New Collection
Dim colPrevHdl As New Collection
Dim colUFHdl As New Collection

Private Function WindowProc(ByVal Lwnd As Long, _
                            ByVal Lmsg As Long, _
                            ByVal Wparam As Long, _
                            ByVal Lparam As Long) As Long
  
Dim Rotacao As Long

If Lmsg = WM_MOUSEWHEEL Then
    Rotacao = Wparam / 65536
    MouseWheel colForm(CStr(Lwnd)), Rotacao
    WindowProc = 0
Else
    WindowProc = CallWindowProc(colPrevHdl(CStr(Lwnd)), Lwnd, _
                                           Lmsg, Wparam, Lparam)
End If
  
End Function
  

Sub UserFormHook(Formulario As UserForm, formCaption As String)
Dim LocalHwnd As Long, LocalPrevWndProc As Long
Dim i As Integer, Erros As Integer

LocalHwnd = FindWindow("ThunderDFrame", formCaption)
LocalPrevWndProc = SetWindowLong(LocalHwnd, GWL_WNDPROC, _
                                 AddressOf WindowProc)

On Error GoTo DupChave
OutraVez:
colForm.Add Formulario, CStr(LocalHwnd)
colPrevHdl.Add LocalPrevWndProc, CStr(LocalHwnd)
colFormHdl.Add LocalHwnd
Exit Sub
  
DupChave:
If Erros = 0 Then
    For i = 1 To colFormHdl.Count
    If colFormHdl(i) = LocalHwnd Then
       colFormHdl.Remove i
       colForm.Remove i
       colPrevHdl.Remove i
    End If
    Next
    Erros = 1
    Resume OutraVez
End If
  
End Sub
  
'Scroll 2 linhas da listbox ou página a página em conjunto com o CTRL
Sub MouseWheel(Formulario As UserForm, ByVal Rodar As Long)
    Dim LinhasListBox As Integer, Linhas2Scroll As Integer 
    Dim xIndex As Integer
    With Formulario
        If TypeName(.ActiveControl) = "ListBox" Then
            LinhasListBox = .ActiveControl.ListCount
            Linhas2Scroll = 2
            If Rodar > 0 Then
              'rodar acima
            xIndex = .ActiveControl.TopIndex - Linhas2Scroll
            If xIndex < 0 Then xIndex = 0
             .ActiveControl.TopIndex = xIndex
            Else
             'rodar abaixo
              xIndex = .ActiveControl.TopIndex + Linhas2Scroll
              If xIndex > LinhasListBox Then xIndex = LinhasListBox
              .ActiveControl.TopIndex = xIndex
            End If
        End If
    End With
End Sub

'Iniciar o Formulário
Sub ShowFormulario()
    UserForm1.Show
End Sub

Colocar no código do Formulário

'Colocar num Userform com uma ListBox
Private Sub UserForm_Initialize()
    For i = 1 To 50
        ListBox1.AddItem "teste item n.º " & i
    Next i
    UserFormHook Me, Me.Caption
End Sub