Listbox-Error: "vom Client getrennt!?"
24.03.2005 15:54:53
Andre
seit neustem hab ich ein ganz "witziges!" Problem:
Ich lasse per VBA eine Listbox füllen, setzte Eigenschaften der Listbox fest und so weiter.
So ziemlich alles über UF.activate und .Initialize.
Beim ersten Start der UF gibt´s kein Problem, alles läuft genauso wie´s soll, aber nachdem ich die UF mittels "Kreuz" oder mittels VBA-Befehl (unloud) schließe und ein zweites Mal starte, bekomme ich folgende Fehlermeldung:
Laufzeitfehler '-2147417848 (80010108)':
Automatisierungsfehler
Das aufgerufene Objekt wurde von den Clients getrennt.
Leider ist dieser Fehler nicht so einfach in einer Beispieldatei nachzustellen, aber vielleicht hat jemand von euch schon mal Erfahrung mit diesem Effekt gemacht und kann mir einen kleinen Trick zeigen, wie ich den Fehler umgehen kann.
Aufgetreten ist dieses Problem erst, nachdem ich mit folgendem Code (aus diesem Forum adaptiert, danke nochmal) versucht hab in der Listbox mit Hilfe der Mouse zu Scrollen. Nehm ich den entsprechenden Befehl aus der UF.Initialize-Prozedur heraus, funzt es wieder, aber ich würde diese Funktion gern erhalten:
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
Btn = Abs(Wparam) And 15
MouseWheel collUF(CStr(Lwnd)), Rotation, Btn
WindowProc = 0
Else
WindowProc = CallWindowProc(collPrevHdl(CStr(Lwnd)), Lwnd, Lmsg, Wparam, Lparam)
End If
End Function
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 Val(Application.Version) > 8 Then
' LocalPrevWndProc = SetWindowLong(hWnd:=LocalHwnd, _
nIndex:=GWL_WNDPROC, _
dwNewLong:=AddrOf_Callback_Routine)
' Else
LocalPrevWndProc = SetWindowLong(hWnd:=LocalHwnd, _
nIndex:=GWL_WNDPROC, _
dwNewLong:=AddressOf WindowProc)
' End If
On Error GoTo DupKey
TryAgain:
collUF.Add PassedForm, CStr(LocalHwnd)
collPrevHdl.Add LocalPrevWndProc, CStr(LocalHwnd)
collUFHdl.Add LocalHwnd
Exit Sub
DupKey:
If cError = 0 Then
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 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)
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
LinesToScroll = Int(.ActiveControl.Height / 10)
Else
LinesToScroll = 1
End If
If Rotation > 0 Then
Idx = .ActiveControl.TopIndex - LinesToScroll
If Idx < 0 Then Idx = 0
.ActiveControl.TopIndex = Idx
Else
Idx = .ActiveControl.TopIndex + LinesToScroll
If Idx > ListRows Then Idx = ListRows
.ActiveControl.TopIndex = Idx
End If
End If
End With
End Sub
Wünsche allen schon mal frohe Feiertage und hoffe jemand hat für diese Problem ´ne Lösung.
Gruß Andre