Scrollrad benutzen in Listen- u. Komb.feldern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi
geht nur unter zur Hilfe name von Windows API Funktionen. Anbei mal etwas Beispielcode (in ein eigenes Modul packen). Basis stammt von Jim Rech, erweitert für Excel 97 Unterstützung:
'---------------------------------------------------------------------------
'Module: mListboxScrol
'Module author: Jim Rech
' Bob Phillips/Frank Kabel - test for XL97 and call custom callbac
'Purpose: Contains all code for enabling mosue wheel scrolling
'---------------------------------------------------------------------------
Option Explicit
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
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 collUF As New Collection
Dim collPrevHdl As New Collection
Dim collUFHdl As New Collection
'---------------------------------------------------------------------------
Public Function WindowProc(ByVal Lwnd As Long, _
ByVal Lmsg As Long, _
ByVal Wparam As Long, _
ByVal Lparam As Long) As Long
'---------------------------------------------------------------------------
Dim Rotation As Long
Dim Btn As Long
If Lmsg = WM_MOUSEWHEEL Then
Rotation = Wparam / 65536 ''High order word indicates direction
Btn = Abs(Wparam) And 15 ''Low order word indicates various virtual keys held down
MouseWheel collUF(CStr(Lwnd)), Rotation, Btn
WindowProc = 0 ''We handled event, no need to pass on (right?)
Else
WindowProc = CallWindowProc(collPrevHdl(CStr(Lwnd)), Lwnd, Lmsg, Wparam, Lparam)
End If
End Function
'---------------------------------------------------------------------------
' Need both userform and its caption because Userform1.Caption is empty for
' some reason
Public Sub UserformHook(PassedForm As UserForm, _
Cap As String)
'---------------------------------------------------------------------------
Dim LocalHwnd As Long
Dim LocalPrevWndProc As Long
Dim cError As Long
Dim i As Long
LocalHwnd = FindWindow("ThunderDFrame", Cap)
'if Excel2000 or above use the built-in AddressOf operator to
'get a pointer to the callback function
If Val(Application.Version) > 8 Then
LocalPrevWndProc = SetWindowLong(hWnd:=LocalHwnd, _
nIndex:=GWL_WNDPROC, _
dwNewLong:=AddrOf_Callback_Routine)
Else 'use K.Getz & M.Kaplan function to get a pointer
LocalPrevWndProc = SetWindowLong(hWnd:=LocalHwnd, _
nIndex:=GWL_WNDPROC, _
dwNewLong:=AddrOf("WindowProc"))
End If
On Error GoTo DupKey 'In case Windows assigns the same handle to a
'subsequent userform (altho it doesn't seem to do this)...
TryAgain:
collUF.Add PassedForm, CStr(LocalHwnd)
collPrevHdl.Add LocalPrevWndProc, CStr(LocalHwnd)
collUFHdl.Add LocalHwnd
Exit Sub
DupKey:
If cError = 0 Then ''Avoid infinite error loop
For i = 1 To collUFHdl.Count
If collUFHdl(i) = LocalHwnd Then
collUFHdl.Remove i
collUF.Remove i
collPrevHdl.Remove i
End If
Next
cError = 1
Resume TryAgain
End If
End Sub
'---------------------------------------------------------------------------
Public Sub UserformUnHook(UF As UserForm)
'---------------------------------------------------------------------------
Dim i As Long
For i = 1 To collUF.Count
If UF Is collUF(i) Then Exit For
Next
''SetWindowLong LocalHwnd, GWL_WNDPROC, LocalPrevWndProc
SetWindowLong collUFHdl(i), GWL_WNDPROC, collPrevHdl(i)
collUF.Remove i
collPrevHdl.Remove i
collUFHdl.Remove i
End Sub
'---------------------------------------------------------------------------
Public Sub MouseWheel(UF As UserForm, _
ByVal Rotation As Long, _
ByVal Btn As Long)
'---------------------------------------------------------------------------
' Function: Scrolls listbox 1 row or a full page if Ctrl is down
'---------------------------------------------------------------------------
Dim LinesToScroll As Long
Dim ListRows As Long
Dim Idx As Long
With UF
If TypeName(.ActiveControl) = "ListBox" Then
ListRows = .ActiveControl.ListCount
If Btn = 8 Then ''Ctrl
LinesToScroll = Int(.ActiveControl.Height / 10) ''Seems to work for font size 8
Else
LinesToScroll = 1
End If
If Rotation > 0 Then
'Scroll up
Idx = .ActiveControl.TopIndex - LinesToScroll
If Idx .ActiveControl.TopIndex = Idx
Else
'Scroll down
Idx = .ActiveControl.TopIndex + LinesToScroll
If Idx > ListRows Then Idx = ListRows
.ActiveControl.TopIndex = Idx
End If
End If
End With
End Sub
'---------------------------------------------------------------------------
' END OF CODE
'---------------------------------------------------------------------------
Und hier der Support für Excel 97 (auch ein eigenes Modul):
'---------------------------------------------------------------------------
' Module: mListboxScrol
' Module author:Ken Getz & Michael Kaplan
' Purpose: Emulates AddressOf for Excel 97
'---------------------------------------------------------------------------
Option Explicit
Option Private Module
'-----------------------------------------------------------------
' Win32 APIs
'-----------------------------------------------------------------
Private Declare Function GetCurrentVbaProject Lib "vba332.dll" _
Alias "EbGetExecutingProj" _
(hProject As Long) As Long
Private Declare Function GetFuncID Lib "vba332.dll" _
Alias "TipGetFunctionId" _
(ByVal hProject As Long, _
ByVal strFunctionName As String, _
ByRef strFunctionID As String) As Long
Private Declare Function GetAddr Lib "vba332.dll" _
Alias "TipGetLpfnOfFunctionId" _
(ByVal hProject As Long, _
ByVal strFunctionID As String, _
ByRef lpfnAddressOf As Long) As Long
'----------------------------------------------------------------------------
Public Function AddrOf(CallbackFunctionName As String) As Long
'----------------------------------------------------------------------------
'AddressOf operator emulator for Office97 VBA
'Authors: Ken Getz and Michael Kaplan
'----------------------------------------------------------------------------
Dim aResult As Long
Dim CurrentVBProject As Long
Dim strFunctionID As String
Dim AddressOfFunction As Long
Dim UnicodeFunctionName As String
'convert the name of the function to Unicode system
UnicodeFunctionName = StrConv(CallbackFunctionName, vbUnicode)
'if the current VBProjects exists...
If Not GetCurrentVbaProject(CurrentVBProject) = 0 Then
'...get the function ID of the callback function, based on its
'unicode-converted name, to ensure that it exists
aResult = GetFuncID(hProject:=CurrentVBProject, _
strFunctionName:=UnicodeFunctionName, _
strFunctionID:=strFunctionID)
'if the function exists indeed ...
If aResult = 0 Then
'...get a pointer to the callback function based on
'the strFunctionID argument of the GetFuncID function
aResult = GetAddr(hProject:=CurrentVBProject, _
strFunctionID:=strFunctionID, _
lpfnAddressOf:=AddressOfFunction)
'if we've got the pointer pass it to the result of the function
If aResult = 0 Then
AddrOf = AddressOfFunction
End If
End If
End If
End Function
'----------------------------------------------------------------------------
Public Function AddrOf_Callback_Routine() As Long
'----------------------------------------------------------------------------
'Office97 VBE does not recognise the AddressOf operator;
'however, it does not raise a compile-error ...
'----------------------------------------------------------------------------
AddrOf_Callback_Routine = vbaPass(AddressOf WindowProc)
End Function
'----------------------------------------------------------------------------


Private Function vbaPass(AddressOfFunction As Long) As Long
vbaPass = AddressOfFunction
End Function

'---------------------------------------------------------------------------
' END OF mAddrOf CODE
'---------------------------------------------------------------------------
Und nun einfach in Deiner Userform (in der Initialisierung) folgende Zeile einfügen:
UserformHook Me, Me.Caption

Beliebteste Forumthreads (12 Monate)

Scrollrad benutzen in Listen- u. Komb.feldern

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Scrollrad benutzen in Listen- u. Komb.feldern

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread