Anzeige
Archiv - Navigation
1864to1868
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

ShowModal False

ShowModal False
26.01.2022 05:45:34
Oraculix
Hallo Alle!
Wenn ich in meiner Combobox scrollen möchte verwende ich den untenstehenden VBA Code.
Sobald ich die Userform aber auf ShowModal False setzte stürzt Excel ab und muss neu gestartet weden.
Frage:
Was muss ich in dem untenstehenden Code ändern damit Excel nicht mehr abstürzt wenn die Userform
ShowModal False gesetzt ist. Im Modus ShowModal True funktoniert der Code einwandfrei.
Hier die Mappe zur Ansicht
https://www.herber.de/bbs/user/150666.xlsm

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call HookMouse(Me, ComboBox1)
End Sub
Option Explicit
Option Private Module
Private Declare PtrSafe Function GetWindowLongPtrA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32.dll" ( _
ByVal point As LongLong) As LongPtr
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32.dll" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As LongPtr)
Private Declare PtrSafe Function SetWindowsHookExA Lib "user32.dll" ( _
ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32.dll" ( _
ByVal hHook As LongPtr, _
ByVal ncode As Long, _
ByVal wParam As LongPtr, _
ByRef lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32.dll" ( _
ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetKeyState Lib "user32.dll" ( _
ByVal nVirtKey As Long) As Integer
Private Declare PtrSafe Function PostMessageA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Type POINTAPI
XY As LongLong
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
Private Const WH_MOUSE_LL As Long = 14&
Private Const WM_MOUSEWHEEL As LongPtr = &H20A
Private Const HC_ACTION As Long = 0&
Private Const GWL_HINSTANCE As Long = -6&
Private Const WM_KEYDOWN As Long = &H100
Private Const SCROLL_DOWN As LongPtr = &H780000
Private Const GP_CLASSNAMEUSERFORM As String = "ThunderDFrame"
Private llngptrMouseHook As LongPtr
Private llngptrControlHwnd As LongPtr
Private llngPage As Long
Private lblnHook As Boolean
Private lobjScrollObject As Object

Public Sub HookMouse(ByRef probjUserform As Object, ByRef probjScrollObject As Object, Optional ByVal opvlngPage As Long)
Dim lngptrHinstance As LongPtr
Dim lngptrFormHwnd As LongPtr
Dim lngptrHwndUnderCursor As LongPtr
Dim udtPoint As POINTAPI
llngPage = opvlngPage
Call GetCursorPos(udtPoint)
lngptrHwndUnderCursor = WindowFromPoint(udtPoint.XY)
If llngptrControlHwnd  lngptrHwndUnderCursor Then
Call UnhookMouse
Set lobjScrollObject = probjScrollObject
llngptrControlHwnd = lngptrHwndUnderCursor
lngptrFormHwnd = FindWindowA(GP_CLASSNAMEUSERFORM, probjUserform.Caption)
lngptrHinstance = GetWindowLongPtrA(lngptrFormHwnd, GWL_HINSTANCE)
If Not lblnHook Then
llngptrMouseHook = SetWindowsHookExA(WH_MOUSE_LL, AddressOf MouseProc, lngptrHinstance, 0&)
lblnHook = llngptrMouseHook  0
End If
End If
End Sub

Public Sub UnhookMouse()
If lblnHook Then
Call UnhookWindowsHookEx(llngptrMouseHook)
Set lobjScrollObject = Nothing
llngptrMouseHook = 0
llngptrControlHwnd = 0
lblnHook = False
End If
End Sub

Private Function MouseProc(ByVal pvlnGPode As Long, ByVal pvlngptrParam As LongPtr, ByRef prudtParam As MOUSEHOOKSTRUCT) As LongPtr
Dim lngptrHwndUnderCursor As LongPtr
On Error GoTo err_exit
If pvlnGPode = HC_ACTION Then
lngptrHwndUnderCursor = WindowFromPoint(prudtParam.pt.XY)
If lngptrHwndUnderCursor = llngptrControlHwnd Then
If pvlngptrParam = WM_MOUSEWHEEL Then
If TypeOf lobjScrollObject Is MSForms.ListBox Or TypeOf lobjScrollObject Is MSForms.ComboBox Then
With lobjScrollObject
If GetKeyState(vbKeyControl) >= 0 Then
If prudtParam.hwnd = SCROLL_DOWN Then
If .TopIndex > 0 Then
If .TopIndex > 3 Then
.TopIndex = .TopIndex - 3
Else
.TopIndex = 0
End If
End If
Else
.TopIndex = .TopIndex + 3
End If
Else
If TypeOf lobjScrollObject Is MSForms.ListBox Then
If prudtParam.hwnd = SCROLL_DOWN Then
Call PostMessageA(llngptrControlHwnd, WM_KEYDOWN, vbKeyLeft, 0)
Else
Call PostMessageA(llngptrControlHwnd, WM_KEYDOWN, vbKeyRight, 0)
End If
End If
End If
End With
ElseIf TypeOf lobjScrollObject Is MSForms.MultiPage Then
With lobjScrollObject.Pages(llngPage)
If GetKeyState(vbKeyControl) >= 0 Then
If prudtParam.hwnd = SCROLL_DOWN Then
If .ScrollTop > 0 Then
.ScrollTop = .ScrollTop - 30
Else
.ScrollTop = 0
End If
Else
.ScrollTop = .ScrollTop + 30
End If
Else
If prudtParam.hwnd = SCROLL_DOWN Then
If .ScrollLeft > 0 Then
.ScrollLeft = .ScrollLeft - 30
Else
.ScrollLeft = 0
End If
Else
.ScrollLeft = .ScrollLeft + 30
End If
End If
End With
ElseIf TypeOf lobjScrollObject Is MSForms.UserForm Or TypeOf lobjScrollObject Is MSForms.Frame Then
With lobjScrollObject
If GetKeyState(vbKeyControl) >= 0 Then
If prudtParam.hwnd = SCROLL_DOWN Then
If .ScrollTop > 0 Then
.ScrollTop = .ScrollTop - 30
Else
.ScrollTop = 0
End If
Else
.ScrollTop = .ScrollTop + 30
End If
Else
If prudtParam.hwnd = SCROLL_DOWN Then
If .ScrollLeft > 0 Then
.ScrollLeft = .ScrollLeft - 30
Else
.ScrollLeft = 0
End If
Else
.ScrollLeft = .ScrollLeft + 30
End If
End If
End With
End If
Exit Function
End If
Else
Call UnhookMouse
End If
End If
MouseProc = CallNextHookEx(llngptrMouseHook, pvlnGPode, pvlngptrParam, ByVal prudtParam)
Exit Function
err_exit:
Call UnhookMouse
End Function
Gruß
Oraculix

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: ShowModal False
26.01.2022 08:39:49
Nepumuk
Hallo,
das passiert wenn du den VBA-Editor offen hast.
Gruß
Nepumuk
Danke Nepumuks Erfahrung genial!!
26.01.2022 08:51:44
Oraculix
Danke Du geniales Genie!!!!! Hier zeigt sich halt Deine Erfahrung!
Was ich herumprobiert habe, und dann ist der VBA Editor schuld.
Gruß
Oraculix
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige