Listbox Scroll

Kristin · 2005-05-10T16:27:56+00:00

Hallo Excel-Freunde, ich hab ja nur eine kleine Frage :) ich habe mir eine Listbox in einer Userform gebastelt - alles super, aber wieso scrollt der Text nicht via Mausrad? Muss ich das etwa extra irgendwie aktivieren? Oder was mache ich falsch? Liebe Grüße und danke für die Mühe, Kristin

Hallo Christoph,
das ist aber auch um Längen zu hoch, nach Nepumuk umschue :-)
Ich habe mir ne Userform mit einer leeren Listbox gebastelt, gestartet wird sie per Button mit tt().
Dann habe ich in alle Proceduren an der ersten Möglichkeit einen Haltepunkt gesetzt. Dann Editor und Fenster nebeneinander, gestartet ud dann mit F8 step by step. Nach jedem Step mal auf die Tabelle oder die UF geklickt, der Code läuft durch, erst beim/nach dem letzten End End, wenn man dann , die Tabelle nur mit der Maus anhaucht steigt Excel aus.
Das nurmal al sinfo für den nachstehenden Code. Ich kann da nix mehr machen bei so hightec Problemen.
Achja. der Autor warnt:
Warning!!!
1- Don't ever forget to UnHook.
2- Unhandled errors will cause Excel to crash.
End of Warning!
IT WORKS SOOOOO GREAT!
Wegen Punkt 2 muss man m.E. das on error resume next durch Fehlerroutinen ersetzen und dann die Fehler auch interpretieren können.
Gruß
Reinhard
(der erst mal googeln muss was hook bzw unhook genau bedeutet)
In ein Modul:
Option Explicit
'To be able to scroll with mouse wheel within Userform
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 Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'To get hWnd long value of the UserForm
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Dim LocalHwnd As Long
Dim LocalPrevWndProc As Long
Dim MyForm As UserForm
Sub tt()
UserForm1.Show
End Sub


Private Function WindowProc(ByVal Lwnd As Long, ByVal Lmsg As Long, ByVal Wparam As Long, ByVal Lparam As Long) As Long
'To handle mouse events
Dim MouseKeys As Long
Dim Rotation As Long
If Lmsg = WM_MOUSEWHEEL Then
MouseKeys = Wparam And 65535
Rotation = Wparam / 65536
'My Form s MouseWheel function
GROUPSDLG.MouseWheel Rotation
End If
WindowProc = CallWindowProc(LocalPrevWndProc, Lwnd, Lmsg, Wparam, Lparam)
End Function

Public Sub WheelHook(PassedForm As UserForm)
'To get mouse events in userform
On Error Resume Next
Set MyForm = PassedForm
LocalHwnd = FindWindow("ThunderDFrame", MyForm.Caption)
LocalPrevWndProc = SetWindowLong(LocalHwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub WheelUnHook()
'To Release Mouse events handling
Dim WorkFlag As Long
On Error Resume Next
WorkFlag = SetWindowLong(LocalHwnd, GWL_WNDPROC, LocalPrevWndProc)
Set MyForm = Nothing
End Sub
In die Userform:


Private Sub UserForm_Activate()
WheelHook Me 'For scrolling support
End Sub


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
WheelUnHook     'For scrolling support
End Sub


Private Sub UserForm_Deactivate()
WheelUnHook     'For scrolling support
End Sub

Public Sub MouseWheel(ByVal Rotation As Long)
'************************************************
' To respond from MouseWheel event
' Scroll accordingly to direction
'
' Made by: Mathieu Plante
' Date: July 2004
'************************************************
If Rotation > 0 Then
'Scroll up
If ListBox1.TopIndex > 0 Then
If ListBox1.TopIndex > 3 Then
ListBox1.TopIndex = ListBox1.TopIndex - 3
Else
ListBox1.TopIndex = 0
End If
End If
Else
'Scroll down
ListBox1.TopIndex = ListBox1.TopIndex + 3
End If
End Sub '***************** End of MouseWheel *****************

Hi Christoph,
hier sind noch 6 Links,
http://groups.google.de/groups?c2coff=1&q=%22Sub+MouseWheel%22&qt_s=Suche
den ersten musste man erst neu formatieren, vielleicht gng da was schief, jetzenfalls hänge ich an Synaxfehler in zeile:
Public Sub Hook(ByVal hControl As Long)
fest.
Gruß
Reinhard

UserForm1:
Private Sub UserForm_Activate()
Dim hwnd As Long
hwnd = hwndFenetreForm(Me.Caption)
If hwnd <> 0 Then Hook hwnd
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnHook
End Sub
Public Sub Controle_ActualiseWheel(Control As MSForms.Control, ByVal sens As Integer)
If sens = -1 Then
If UserForm1.ScrollBar1 - UserForm1.ScrollBar1.SmallChange > UserForm1.ScrollBar1.Min Then UserForm1.ScrollBar1 = UserForm1.ScrollBar1 - UserForm1.ScrollBar1.SmallChange
Else
UserForm1.ScrollBar1 = UserForm1.ScrollBar1.Min
End If
Else
If UserForm1.ScrollBar1 + UserForm1.ScrollBar1.SmallChange < UserForm1.ScrollBar1.Max Then UserForm1.ScrollBar1 = UserForm1.ScrollBar1 + UserForm1.ScrollBar1.SmallChange
Else
UserForm1.ScrollBar1 = UserForm1.ScrollBar1.Max
End If
End If
End Sub
'Modul1:
'Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
'Private Declare Function CallWindowProc Lib "" ()
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 Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const MK_CONTROL = &H8
Public Const MK_LBUTTON = &H1
Public Const MK_RBUTTON = &H2
Public Const MK_MBUTTON = &H10
Public Const MK_SHIFT = &H4
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Private hControl As Long
Private lPrevWndProc As Long
'appelée quand l'événement mousewheel est déclenché
Private Sub MouseWheel(ByVal fwKeys As Long, _
ByVal zDelta As Long, _
ByVal xPos As Long, _
ByVal yPos As Long)
Dim sens As Integer
If UserForm1.ActiveControl.Name <> "ScrollBar1" Then
Exit Sub
If zDelta < 0 Then sens = 1 Else sens = -1
UserForm1.Controle_ActualiseWheel
UserForm1.ActiveControl , sens
End Sub
Private Function WindowProc(ByVal lWnd As Long, _
ByVal lMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim fwKeys As Long
Dim zDelta As Long, xPos As Long, yPos As Long
If lMsg = WM_MOUSEWHEEL Then
fwKeys = wParam And 65535
zDelta = wParam / 65536
xPos = lParam And 65535
yPos = lParam / 65536
MouseWheel fwKeys, zDelta, xPos, yPos
End If
WindowProc = CallWindowProc(lPrevWndProc, lWnd, lMsg, wParam, lParam)
End Function
'Hook
Public Sub Hook(ByVal hControl As Long)
lPrevWndProc = SetWindowLong(hControl, GWL_WNDPROC, AddressOfWindowProc)
End Sub
'UnHook
Public Sub UnHook()
Call SetWindowLong(hControl, GWL_WNDPROC, lPrevWndProc)
End Sub
Function DCFenetreForm(CaptionFenetre As String) As Long
Dim hwnd As Long
'renvoie le hdc d'un UserForm (mais pas d'un contrôle)
hwnd = FindWindow(vbNullString, Me.Caption)
'hwnd = FindWindow(vbNullString, CaptionFenetre)
DCFenetreForm = GetDC(hwnd)
End Function
Function hwndFenetreForm(CaptionFenetre As String) As Long
hwndFenetreForm = FindWindow(vbNullString, CaptionFenetre)
End Function
Function HwndFenetreXL() As Long
HwndFenetreXL = FindWindow("XLMAIN", Application.Caption)
End Function
wort, "*") + 1))
End Function

Forumthread: Listbox Scroll

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

Listbox Scroll in Excel VBA

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)