Generic MouseWheel Scroll for UserForm and for ALL its Controls !

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,560
Office Version
2016
Platform
Windows
Hi all,
Below is a code for scrolling all controls in a userform with the Mouse Wheel

Should work with Modal as well as with Modeless userforms .. Tested in 32Bit and 64Bit systems .. Also, the code doesn't use a Windows hook so it should be stable and safe.

See Workbook Demo

1- Code in a Standard Module :
Code:
Option Explicit

Public Enum CTRL_KEY_PRESS_STATE
    Released
    Pressed
End Enum

Public Enum WHEEL_ROTATION
    Forward
    Backward
End Enum

Private Type POINTAPI
  X As Long
  Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type LongToInteger
    Low As Integer
    High As Integer
End Type

#If VBA7 Then
    Private Type MSG
        hwnd As LongPtr
        message As Long
        wParam As LongPtr
        lParam As LongPtr
        time As Long
        pt As POINTAPI
    End Type
    
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As LongPtr)
    Private Declare PtrSafe Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As LongPtr) As Long
#If Win64 Then
     Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
#Else
     Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If

#Else
    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg 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 AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
    Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
#End If
 
Private Const CHILDID_SELF = &H0&
Private Const S_OK As Long = &H0
Private Const POINTSPERINCH As Long = 72
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const WM_MOUSEWHEEL = &H20A
Private Const PM_REMOVE = &H1
Private bCancelProcessing As Boolean
Private Const MK_CONTROL = &H8
Private Const SCROLL_CHANGE = 10

Private arObjCaptions() As Variant
Private arObjPointers() As Variant

Public Sub HookMouseWheelScroll(ByVal UF As Object)
    Dim WheelRotation As WHEEL_ROTATION
    Dim CtrlKey As CTRL_KEY_PRESS_STATE
    Dim tMsg As MSG
    Dim tCurPos As POINTAPI
    Dim oIA As IAccessible
    Dim oObjUnderMouse As Object
    Dim oPage As Object
    Dim oCtrl As Object
    Dim vKid  As Variant
    Dim i As Long
    Dim j As Long
    Dim lResult As Long
    Dim bCancel As Boolean
    Static k As Long
    #If VBA7 Then
        Dim Ptr As LongPtr
    #Else
        Dim Ptr As Long
    #End If
    
    bCancelProcessing = False
    k = 0
    UF.Caption = UF.Caption & Chr(10)
    j = 0
    Erase arObjCaptions
    Erase arObjPointers
    For Each oCtrl In UF.Controls
        If TypeName(oCtrl) = "MultiPage" Then
            For Each oPage In oCtrl.Pages
                i = i + 1
                oPage.Caption = oPage.Caption & String(i, Chr(10))
                ReDim Preserve arObjCaptions(j)
                ReDim Preserve arObjPointers(j)
                arObjCaptions(j) = oPage.Caption & Chr(10)
                arObjPointers(j) = ObjPtr(oPage)
                j = j + 1
            Next
        End If
    Next
    Do While Not bCancelProcessing
        DoEvents
        GetCursorPos tCurPos
        #If Win64 Then
            CopyMemory Ptr, tCurPos, LenB(tCurPos)
            lResult = AccessibleObjectFromPoint(Ptr, oIA, vKid)
        #Else
            lResult = AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
        #End If
        If lResult = S_OK Then
            On Error Resume Next
            Set oObjUnderMouse = objUnderMouse(UF, oIA, tCurPos)
            If Not oObjUnderMouse Is Nothing Then
                WaitMessage
                If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then
                    CtrlKey = IIf(LoWord(CLng(tMsg.wParam)) = MK_CONTROL, Pressed, Released)
                    WheelRotation = IIf(tMsg.wParam > 0, Forward, Backward)
                    Call UF.OnScrollEvent(oObjUnderMouse, WheelRotation, CtrlKey, tMsg.pt.X, tMsg.pt.Y, bCancel)
                    If Not bCancel Then
                        If TypeName(oObjUnderMouse) = "TextBox" Then
                            With oObjUnderMouse
                                .SetFocus
                                If k = 0 Then
                                    .SelStart = 0
                                Else
                                    .SelStart = IIf(.SelStart = .LineCount, 0, .SelStart)
                                End If
                                If WheelRotation = Forward Then
                                    .CurLine = .CurLine - 1
                                Else
                                    .CurLine = IIf(.CurLine = .LineCount - 1, .CurLine, .CurLine + 1)
                                End If
                            End With
                            k = k + 1
                        End If
                        If TypeName(oObjUnderMouse) = "ScrollBar" Then
                            With oObjUnderMouse
                                If WheelRotation = Forward Then
                                    .Value = IIf(.Value - oObjUnderMouse.SmallChange > .Min, .Value - oObjUnderMouse.SmallChange, .Min)
                                Else
                                    .Value = IIf(.Value + oObjUnderMouse.SmallChange < .Max, .Value + oObjUnderMouse.SmallChange, .Max)
                                End If
                            End With
                        End If
                        If TypeName(oObjUnderMouse) = "ListBox" Or TypeName(oObjUnderMouse) = "ComboBox" Then
                            With oObjUnderMouse
                                If CtrlKey = Released Then
                                    If WheelRotation = Forward Then
                                    .TopIndex = .TopIndex - 1
                                    Else
                                    .TopIndex = .TopIndex + 1
                                    End If
                                Else
                                    .SetFocus
                                    If WheelRotation = Forward Then
                                        SendKeys "{LEFT}", True
                                        DoEvents
                                        SendKeys "{RIGHT}", True
                                    Else
                                        SendKeys "{RIGHT}", True
                                        DoEvents
                                        SendKeys "{RIGHT}", True
                                    End If
                                End If
                            End With
                        End If
                        If TypeName(oObjUnderMouse) = UF.Name Or TypeName(oObjUnderMouse) = "Frame" Or TypeName(oObjUnderMouse) = "Page" Then
                            With oObjUnderMouse
                                If CtrlKey = Released Then
                                    If WheelRotation = Forward Then
                                        .ScrollTop = Application.Max(0, .ScrollTop - 5)
                                    Else
                                        .ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + SCROLL_CHANGE)
                                    End If
                                Else
                                    If WheelRotation = Forward Then
                                        .ScrollLeft = Application.Max(0, .ScrollLeft - 5)
                                    Else
                                        .ScrollLeft = Application.Min(.ScrollWidth - .InsideWidth, .ScrollLeft + SCROLL_CHANGE)
                                    End If
                                End If
                            End With
                        End If
                    End If
                    DoEvents
                End If
            End If
        End If
    Loop
End Sub

Public Sub RemoveMouseWheelHook()
    bCancelProcessing = True
End Sub

[B][COLOR=#008000]'Private Routines ..[/COLOR][/B]
[B][COLOR=#008000]'-------------------[/COLOR][/B]
Private Function objUnderMouse(ByVal UF As Object, ByVal oAcc As IAccessible, MouseLoc As POINTAPI) As Object
    #If VBA7 Then
        Dim lngPtr As LongPtr
        Dim lObjPtr As LongPtr
        Dim lCtrlPtr As LongPtr
        Dim hwndForm As LongPtr
        Dim hwndFromPoint As LongPtr
    #Else
        Dim lObjPtr As Long
        Dim lCtrlPtr As Long
        Dim hwndForm As Long
        Dim hwndFromPoint As Long
    #End If
    Dim arCtrlsPosition() As Variant
    Dim arCtrlsPointers() As Variant
    Dim tPt As POINTAPI
    Dim tRect As RECT
    Dim oObj As Object
    Dim oCtrl As Control
    Dim sBuffer As String
    Dim lCtrlLeft As Long
    Dim lCtrlTop As Long
    Dim lPos1 As Long
    Dim lPos2 As Long
    Dim lPos3 As Long
    Dim lRet As Long
    Dim i As Long

    On Error Resume Next
    hwndForm = FindWindow(vbNullString, UF.Caption)
    For Each oCtrl In UF.Controls
        ReDim Preserve arCtrlsPosition(i + 1)
        ReDim Preserve arCtrlsPointers(i + 1)
        tPt = GetRealCtrlScreenLocation(oCtrl, hwndForm, UF)
        arCtrlsPosition(i) = tPt.X & tPt.Y
        arCtrlsPointers(i) = ObjPtr(oCtrl)
        arCtrlsPosition(i + 1) = tPt.X - 2 & tPt.Y - 1
        arCtrlsPointers(i + 1) = ObjPtr(oCtrl)
        i = i + 2
    Next
    lPos1 = WorksheetFunction.Match(oAcc.accName(CHILDID_SELF) & Chr(10), arObjCaptions, 0)
    lObjPtr = WorksheetFunction.Index(arObjPointers, 1, lPos1)
    Call oAcc.accLocation(lCtrlLeft, lCtrlTop, 0, 0, CHILDID_SELF)
    lPos2 = WorksheetFunction.Match(lCtrlLeft & lCtrlTop, arCtrlsPosition, 0)
    lCtrlPtr = WorksheetFunction.Index(arCtrlsPointers, 1, lPos2)
    #If VBA7 Then
        CopyMemory lngPtr, MouseLoc, LenB(MouseLoc)
        hwndFromPoint = WindowFromPoint(lngPtr)
    #Else
        hwndFromPoint = WindowFromPoint(MouseLoc.X, MouseLoc.Y)
    #End If
    sBuffer = Space(256)
    lRet = GetClassName(GetParent(hwndFromPoint), sBuffer, 256)
    lPos3 = InStr(1, Left(sBuffer, lRet), "MdcPopup")
    Select Case True
        Case lPos3 <> 0
            Set objUnderMouse = GetActiveComboBox(UF)
            Exit Function
        Case oAcc.accName(CHILDID_SELF) = UF.Caption
            Set oObj = UF
        Case lObjPtr = 0
            If IsBadCodePtr(lCtrlPtr) = 0 Then
                CopyMemory oObj, lCtrlPtr, 4
            End If
        Case lObjPtr <> 0
            If IsBadCodePtr(lObjPtr) = 0 Then
                CopyMemory oObj, lObjPtr, 4
            End If
    End Select
    Set objUnderMouse = oObj
    If Not oObj Is Nothing Then
        ZeroMemory oObj, 4
    End If
End Function

#If VBA7 Then
    Private Function GetRealCtrlScreenLocation(ByVal Ctl As Object, ByVal hwnd As LongPtr, ByVal UF As Object) As POINTAPI
#Else
    Private Function GetRealCtrlScreenLocation(ByVal Ctl As Object, ByVal hwnd As Long, ByVal UF As Object) As POINTAPI
#End If
    Dim tRect As RECT
    Dim tTopLeft As POINTAPI
    Dim oMultiPage As Control
    Dim oTempObj As Control

    On Error Resume Next
    Set oTempObj = Ctl.Parent
    With tTopLeft
        Select Case True
             Case oTempObj Is Nothing
                .X = PTtoPX(Ctl.Left - UF.ScrollLeft * UF.Zoom / 100, False)
                .Y = PTtoPX(Ctl.Top - UF.ScrollTop * UF.Zoom / 100, True)
                ClientToScreen hwnd, tTopLeft
             Case TypeName(oTempObj) = "Frame"
                GetWindowRect oTempObj.[_GethWnd], tRect
                .X = PTtoPX(Ctl.Left - oTempObj.ScrollLeft * (oTempObj.Zoom / 100), False) + tRect.Left + 2
                .Y = PTtoPX(Ctl.Top - oTempObj.ScrollTop * (oTempObj.Zoom / 100), True) + tRect.Top + 8
            Case TypeName(oTempObj) = "Page"
                Set oMultiPage = oTempObj.Parent
                GetWindowRect GetNextWindow(oMultiPage.[_GethWnd], 5), tRect
                .X = PTtoPX(Ctl.Left - oTempObj.ScrollLeft * (oTempObj.Zoom / 100), False) + tRect.Left
                .Y = PTtoPX(Ctl.Top - oTempObj.ScrollTop * (oTempObj.Zoom / 100), True) + tRect.Top
                Set oMultiPage = Nothing
            End Select
        End With
    GetRealCtrlScreenLocation = tTopLeft
    Set oTempObj = Nothing
End Function

Private Function GetActiveComboBox(ByVal Ctl As Object) As Control
    Dim oCtl As Object
    Dim lCur As Long
    On Error Resume Next
    For Each oCtl In Ctl.Controls
        Err.Clear
        lCur = oCtl.CurX
        If Err.Number = 0 And TypeName(oCtl) = "ComboBox" Then Set GetActiveComboBox = oCtl: Exit Function
    Next
End Function

Private Function LoWord(ByVal Word As Long) As Integer
    Dim X As LongToInteger
    CopyMemory X, Word, LenB(X)
    LoWord = X.Low
End Function

Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    Static lDPI(1), lDC
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function
2- Code in the UserForm Module:
Code:
Option Explicit

Private Sub UserForm_Activate()
    Dim i As Long
    
    [B][COLOR=#008000]'Populate the controls[/COLOR][/B]
    For i = 0 To 100
        With ListBox1
            .ColumnCount = 4
            .ColumnWidths = "100;100;100;100"
            .AddItem "COLUMN1"
            .List(i, 1) = "COLUMN2"
            .List(i, 2) = "COLUMN3"
            .List(i, 3) = "COLUMN4"
        End With
        ListBox2.AddItem i
        ComboBox1.AddItem i
        ComboBox2.AddItem i
        ComboBox3.AddItem i
        ComboBox4.AddItem i
        ComboBox5.AddItem i
        ComboBox6.AddItem i
        ComboBox7.AddItem i
        ComboBox8.AddItem i
        ComboBox9.AddItem i
    Next i
    With TextBox1
        .Text = .Text & String(300, "A")
        .Text = .Text & String(300, "I")
        .Text = .Text & String(300, "X")
    End With
    Label1.Caption = "Object :"
    Label2.Caption = "Wheel Rotation :"
    Label3.Caption = "Scroll Direction :"
    Label4.Caption = "Cursor X :"
    Label5.Caption = "Cursor Y :"
    Label6.Caption = "Scroll Cancelled :"
    
    [B][COLOR=#008000]'Hook MouseWheel Scroll of Form and of all its controls[/COLOR][/B]
    Call HookMouseWheelScroll(Me)

End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call RemoveMouseWheelHook
End Sub
Private Sub CommandButton1_Click()
    Unload Me
End Sub
[B][COLOR=#008000]
'-------------------------[/COLOR][/B]
[B][COLOR=#008000]'Public Generic event[/COLOR][/B]
[B][COLOR=#008000]'-------------------------[/COLOR][/B]

Public Sub OnScrollEvent(ByVal Obj As Object, ByVal WheelRotation As WHEEL_ROTATION, _
ByVal CtrlKey As CTRL_KEY_PRESS_STATE, ByVal X As Long, ByVal Y As Long, Cancel As Boolean)

    Dim sObjName As String, sWheelRot As String, sCtrlKey As String
    Dim sCurX As String, sCurY As String, sCancelScrol As String
    
    sObjName = "Object :  (" & Obj.Name & ")"
    sWheelRot = "Wheel Rotation :  (" & IIf(WheelRotation = Forward, "Forward", "Backward") & ")"
    sCtrlKey = "Scroll Direction :  (" & IIf(CtrlKey = Released, "Vert", "Horiz") & ")"
    sCurX = "Cursor X :  (" & X & ")"
    sCurY = "Cursor Y :  (" & Y & ")"
    sCancelScrol = "Scroll Cancelled :  (" & Cancel & ")"
    
    Label1.Caption = sObjName
    Label2.Caption = sWheelRot
    Label3.Caption = sCtrlKey
    Label4.Caption = sCurX
    Label5.Caption = sCurY
    Label6.Caption = sCancelScrol
End Sub
 

dan0291

New Member
Joined
Oct 12, 2016
Messages
2
I'm receiving the following error when I run this:

Run-time error '-2147417848 (80010108)':
Automation error
The object invoked has disconnected from its clients.


Any idea what could be causing this?
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,560
Office Version
2016
Platform
Windows
I'm receiving the following error when I run this:

Run-time error '-2147417848 (80010108)':
Automation error
The object invoked has disconnected from its clients.


Any idea what could be causing this?
Did you add some of your own code ?
 
Last edited:

Ingolf

Banned
Joined
Mar 20, 2011
Messages
809
With your workbook Demo I get same message like dan0921:


Run-time error '-2147417848 (80010108)':
Automation error
The object invoked has disconnected from its clients.

The message appear after click button from sheet.
 

AddinBox_Tsunoda

Board Regular
Joined
Feb 23, 2012
Messages
63
Me, too.

> Did you add some of your own code ?
Nothing.


Win10Pro(x64)
Office2010 Pro Plus(x86) SP2

I abort it in CopyMemory of MainBas/objUnderMouse of the processing to continue from UserForm_Activate/[Call HookMouseWheelScroll(Me)].


 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,560
Office Version
2016
Platform
Windows
I have tested the code again on two different machines Win7 Pro-32Bit Office 2007 and Win10-32Bit Office 2010 32-Bit and the code worked flawlessly on both machines.

I have read that the error you are experiencing often happens if an unqualified call is made to a Property or Method of an Office object.

Try fully qualifiying the call to the WorksheetFunction Property as follows and see if it works :

Code:
    lPos1 = [B][COLOR=#ff0000]Application.[/COLOR][/B]WorksheetFunction.Match(oAcc.accName(CHILDID_SELF) & Chr(10), arObjCaptions, 0)
     lObjPtr = [COLOR=#ff0000][B]Application.[/B][/COLOR]WorksheetFunction.Index(arObjPointers, 1, lPos1)
    Call oAcc.accLocation(lCtrlLeft, lCtrlTop, 0, 0, CHILDID_SELF)
    lPos2 = [COLOR=#ff0000][B]Application.[/B][/COLOR]WorksheetFunction.Match(lCtrlLeft & lCtrlTop, arCtrlsPosition, 0)
    lCtrlPtr = [COLOR=#ff0000][B]Application.[/B][/COLOR]WorksheetFunction.Index(arCtrlsPointers, 1, lPos2)
    #If VBA7 Then
        CopyMemory lngPtr, MouseLoc, LenB(MouseLoc)
        hwndFromPoint = WindowFromPoint(lngPtr)
    #Else
 

AddinBox_Tsunoda

Board Regular
Joined
Feb 23, 2012
Messages
63
Hi, Jaafar.

I added "Application.", but after all become the error.

It becomes the error in the same way in Office2016 Pro Plus(x86)/Win10Pro(x64).


In addition, contents of lPos1/lObjPtr/lPos2/lCtrlPtr turn out whether it is following which at every Excel reboot.

Code:
lPos1    = 0
lObjPtr  = 0
lPos2    = 31
lCtrlPtr = any Pointer address (e.g.  229466616)
or
Code:
lPos1    = 3
lObjPtr  = any Pointer address (e.g.  229466616)
lPos2    = 0
lCtrlPtr = 0
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,560
Office Version
2016
Platform
Windows
@Tsunoda.

Thanks for testing the code .

Have you tried removing the WorkSheetFunction and replacing it with Application only - ie :

from
Code:
[COLOR=#ff0000][B]Application.[/B][/COLOR][COLOR=#333333]WorksheetFunction.Match[/COLOR]
to
Code:
[COLOR=#ff0000][B]Application.[/B][/COLOR][COLOR=#333333]Match[/COLOR]
The same with Index.
 

AddinBox_Tsunoda

Board Regular
Joined
Feb 23, 2012
Messages
63
Hi, Jaafar.

> In addition, contents of lPos1/lObjPtr/lPos2/lCtrlPtr turn out
> whether it is following which at every Excel reboot.
Sorry.
It is the result by the difference of the position of the momentary mouse pointer that UserForm was displayed.
Code:
I display it with the CommandButton of the worksheet or with the practice button of VBE.
And, the difference of the position of two buttons.
And, did I move a mouse after a button click?

> Application.Match
I changed "Application.Match", but after all become the error at Excel2010/2016.




It worked in Excel2003(SP3).
The scroll bar of Frame & ListBox control changes in conjunction with a mouse wheel without a problem.
However, it becomes the error at the moment when mouse pointer appeared on SpinButton/ScrollBar control.



I sleep from now on today. See you tomorrow.
 

GTO

MrExcel MVP
Joined
Dec 9, 2008
Messages
6,154
Greetings Jaafar,


I hope my observations are not totally out-to-lunch, but in case of any help, here is what I have experienced:


Setup: (At work and no internet at home currently, so could not download the example. A pity.)
Userform1 with 6 labels, 2 listboxes, 9 comboboxes, 1 textbox, 1 commandbutton - all default named.
I didn't notice the code for the multipage for a bit, but tacked on a multipage (w/no controls) later.
All code as shown at #1.


To call the form, I used:
Rich (BB code):
Option Explicit


Private frm As UserForm1


Sub A_RunForm()


  Set frm = New UserForm1
  frm.Show vbModal
  
  Set frm = Nothing
  
End Sub


Sub B_RunForm()
  
  Set frm = New UserForm1
  frm.Show vbModeless
  
End Sub


Sub B_RemoveRef()
  Set frm = Nothing
End Sub

Originally saved in .xls, but now in .xlsm


Environment: WIN7 Enterprise w/SP1 64-bit; Office Professional Plus 2010 (32-bit)


The first few times I ran it, I got similar results as mentioned.


Run-time error '-2147417848(80010108)':


Automation error
The object invoked has disconnected from its clients


I noted that the form stayed displayed after the error and the controls appear to remain functional; absent any mousewheel capability of course. After unloading the form though, I could close the workbook, but Excel didn't want to shutdown; required ending process through task manager.


In later testing, I did not notice any difference between which way we qualified MATCH or INDEX, but after having run the book a number of times, Excel started warning and exiting without being able to debug.


I noted that in placing Stop(s) and stepping thu in various places, the error seems to always happen at CopyMemory (about line 294). Here is where I took a chance, based upon the declarations in Win32API_PtrSafe.TXT. I changed declarations under #If VBA7


Rich (BB code):
    'Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
    Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr

and in the code, I changed:


Rich (BB code):
    'lPos1 = WorksheetFunction.Match(oAcc.accName(CHILDID_SELF) & Chr(10), arObjCaptions, 0)
    lPos1 = Application.Match(oAcc.accName(CHILDID_SELF) & Chr(10), arObjCaptions, 0)
    'lObjPtr = WorksheetFunction.Index(arObjPointers, 1, lPos1)
    lObjPtr = Application.Index(arObjPointers, 1, lPos1)
    Call oAcc.accLocation(lCtrlLeft, lCtrlTop, 0, 0, CHILDID_SELF)
    'lPos2 = WorksheetFunction.Match(lCtrlLeft & lCtrlTop, arCtrlsPosition, 0)
    lPos2 = Application.Match(lCtrlLeft & lCtrlTop, arCtrlsPosition, 0)
    'lCtrlPtr = WorksheetFunction.Index(arCtrlsPointers, 1, lPos2)
    lCtrlPtr = Application.Index(arCtrlsPointers, 1, lPos2)
    
    #If VBA7 Then
'        CopyMemory lngPtr, MouseLoc, LenB(MouseLoc)
'        hwndFromPoint = WindowFromPoint(lngPtr)
        hwndFromPoint = WindowFromPoint(MouseLoc.x, MouseLoc.Y)
    #Else
        hwndFromPoint = WindowFromPoint(MouseLoc.x, MouseLoc.Y)
    #End If

I hope I am not wasting your time (or mine for that matter), as you know my understanding of API is awfully limited. But FWIW, it seems to work flawlessly now :)


I think I grasp that if in 64-bit, then maybe we have to declare it with just the one argument of type/struct POINTAPI ???


Anywyas, I am ghastly overdue elsewhere and beat, so will check back Sunday night. It's übercool to see it work!

A great weekend to you and all,

Mark
 

Forum statistics

Threads
1,085,519
Messages
5,384,163
Members
401,885
Latest member
nirmalpatel85

Some videos you may like

This Week's Hot Topics

Top