[VBA] combobox, reverse of dropdown?

[smallxyz]

Upon mouse hovering, the combobox will automatically drop down the list.
Upon mouse leaving region of combobox, the list will automatically scroll up.

The first task can be done using combobox.dropdown.
However, how to handle second task?
Any ideas?

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    With ComboBox1
        Xmar = 10
        Ymar = 10
        
        If (X > Xmar And X < .Width - Xmar) And (Y > Ymar And Y < .Height - Ymar) Then
            
            .DropDown
            
        Else


            ' reverse of Dropdown


        End If
    End With
End Sub

Thanks a lot!

 

[smallxyz]

Sos

 

[Jaafar Tribak]

@smallxyz

Is the combobox control on a userform or on a worksheet ?

 

[gatindetuin]

@smallxyz

Is the combobox control on a userform or on a worksheet ?

Have the same question, in my case the combobox is on the sheet.

 

[Jaafar Tribak]

Have the same question, in my case the combobox is on the sheet.

@gatindetuin

If the combobox is on a worksheet (as opposed to a combobox on a userform) then it is very tricky to detect when the mouse leaves the combobox .

In my first tests,I tried using the Microsoft Active Accessibility but it turned out to be of no use as it doesn't retrieve the dropDown section of the combobox when the latter is expanded neither does it retrieve the surrounding cells.

IMHO, The only thing that I think might work is using the UIAutomation lib and even if that works it will require some complicated API code specially if the automation dll is not loaed & referenced in the project at design time .

However, just out of curiosity, I'll try to write the code and if anything comes up I'll post it here.

Regards.

 

[Jaafar Tribak]

Here is an example that shows how we can make use of the MS UIAutomationClient library at runtime (No lib ref required) in order to find a solution to this problem.

Workbook example.

The code is complicated but it is fun and good for learning purposes.


1- API code in a Standard Module:

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As GUID) As Long
    Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function SysReAllocString Lib "oleAut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
    Private Declare PtrSafe Function SetProcessDPIAware Lib "user32" () As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As Currency) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
    Private Declare Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As Long, ByVal cchMax As Long) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As Long, ByRef cGUID As GUID) As Long
    Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As Long) As Long
    Private Declare Function SysReAllocString Lib "oleAut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
    Private Declare Function SetProcessDPIAware Lib "user32" () As Long
    Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As Currency) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If


Public bMonitoring As Boolean
Public bWBClosing As Boolean


Public Sub MonitorMouseLeave(ByVal obj As Object)

    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
            Const PTR_FACTOR = 2
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
            Const PTR_FACTOR = 1
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
        Dim pAuto As LongPtr
        Dim pElement As LongPtr
        Dim pCurrentName As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Const PTR_FACTOR = 1
        Dim pAuto As Long
        Dim pElement As Long
        Dim pCurrentName As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Const S_OK = 0&
    Const CLSCTX_INPROC_SERVER = &H1
    Const CC_STDCALL = 4&
    Const IUnknownRelease = 8&
    Const IID_CUIAUTOMATION = "{FF48DBA4-60EF-4201-AA87-54103EEF594E}"
    Const IID_IUIAUTOMATION = "{30CBE57D-D9D0-452A-AB13-7AC5AC4825EE}"

    Dim iidCuiAuto As GUID, iidIuiAuto As GUID, tPt As Currency
    Dim lRet As Long, VTableOffset As Long
    
    On Error Resume Next

    Call SetProcessDPIAware
    
    Do
    
        If bWBClosing Then bWBClosing = False: bMonitoring = False: Exit Sub
    
        bMonitoring = True
        
        lRet = CLSIDFromString(StrPtr(IID_CUIAUTOMATION), iidCuiAuto)
        Call DispGUID(iidCuiAuto)
        lRet = CLSIDFromString(StrPtr(IID_IUIAUTOMATION), iidIuiAuto)
        Call DispGUID(iidIuiAuto)
        lRet = CoCreateInstance(iidCuiAuto, 0, CLSCTX_INPROC_SERVER, iidIuiAuto, pAuto)
        
        If lRet = S_OK Then
            Call GetCursorPos(tPt)
            VTableOffset = 28 * PTR_FACTOR
            lRet = CallFunction_COM(pAuto, VTableOffset, vbLong, CC_STDCALL, tPt, VarPtr(pElement))
            If lRet = S_OK Then
                VTableOffset = 92 * PTR_FACTOR
                lRet = CallFunction_COM(pElement, VTableOffset, vbLong, CC_STDCALL, VarPtr(pCurrentName))
                If lRet = S_OK Then
                    If Len(GetStrFromPtrW(pCurrentName)) And GetStrFromPtrW(pCurrentName) <> "Rectangle" Then
                        Call RunMacro(obj)
                        bMonitoring = False
                        Exit Do
                    End If
                    Call CallFunction_COM(pElement, IUnknownRelease, vbLong, CC_STDCALL)
                End If
                Call CallFunction_COM(pAuto, IUnknownRelease, vbLong, CC_STDCALL)
            End If
        End If
        DoEvents
        
    Loop

End Sub


Private Sub RunMacro(ByVal obj As Object)
    obj.Activate
    ActiveCell.Select
    bMonitoring = False
End Sub


[COLOR=#008000]
'////////////////
'HELPER ROUTINES:
'////////////////[/COLOR]
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function CallFunction_COM(ByVal InterfacePointer As LongPtr, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
        Dim vParamPtr() As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function CallFunction_COM(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
        Dim vParamPtr() As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0 To 0)
        ReDim vParamType(0 To 0)
    Else
        ReDim vParamPtr(0 To pCount - 1&)
        ReDim vParamType(0 To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

     pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, vParamType(0), vParamPtr(0), vRtn)

    If pIndex = 0& Then
        CallFunction_COM = vRtn
    Else
        SetLastError pIndex
    End If
End Function


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function GetStrFromPtrW(ByVal Ptr As LongPtr) As String
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function GetStrFromPtrW(ByVal Ptr As Long) As String
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    SysReAllocString VarPtr(GetStrFromPtrW), Ptr
    
End Function


Private Sub DispGUID(objGuid As GUID)

    Dim lRet As Long
    Dim sTmp As String
    Dim buf(100) As Byte
    
    lRet = StringFromGUID2(objGuid, VarPtr(buf(0)), UBound(buf) - 1)
    sTmp = buf
    
End Sub

2- Code in the Worksheet Module that contains ComboBox1

Option Explicit

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If bMonitoring = False Then
        ComboBox1.DropDown
        Call MonitorMouseLeave(Me.ComboBox1)
    End If
End Sub

3- Safety exit code in the ThisWorkbook Module:

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    bWBClosing = True
End Sub