Results 1 to 6 of 6

Thread: [VBA] combobox, reverse of dropdown?
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    Board Regular
    Join Date
    Jul 2015
    Posts
    366
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default [VBA] combobox, reverse of dropdown?

    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?


    Code:
    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!

  2. #2
    Board Regular
    Join Date
    Jul 2015
    Posts
    366
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: [VBA] combobox, reverse of dropdown?

    Sos

  3. #3
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,398
    Post Thanks / Like
    Mentioned
    40 Post(s)
    Tagged
    3 Thread(s)

    Default Re: [VBA] combobox, reverse of dropdown?

    @smallxyz

    Is the combobox control on a userform or on a worksheet ?
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  4. #4
    New Member
    Join Date
    Sep 2019
    Posts
    1
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: [VBA] combobox, reverse of dropdown?

    Quote Originally Posted by Jaafar Tribak View Post
    @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.

  5. #5
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,398
    Post Thanks / Like
    Mentioned
    40 Post(s)
    Tagged
    3 Thread(s)

    Default Re: [VBA] combobox, reverse of dropdown?

    Quote Originally Posted by gatindetuin View Post
    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.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  6. #6
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,398
    Post Thanks / Like
    Mentioned
    40 Post(s)
    Tagged
    3 Thread(s)

    Default Re: [VBA] combobox, reverse of dropdown?

    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:
    Code:
    Option Explicit
    
    Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(0 To 7) As Byte
    End Type
    
    #If  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
    #Else 
        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
    #End  If
    
    
    Public bMonitoring As Boolean
    Public bWBClosing As Boolean
    
    
    Public Sub MonitorMouseLeave(ByVal obj As Object)
    
        #If  VBA7 Then
            #If  Win64 Then
                Const PTR_FACTOR = 2
            #Else 
                Const PTR_FACTOR = 1
            #End  If
            Dim pAuto As LongPtr
            Dim pElement As LongPtr
            Dim pCurrentName As LongPtr
        #Else 
            Const PTR_FACTOR = 1
            Dim pAuto As Long
            Dim pElement As Long
            Dim pCurrentName As Long
        #End  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
    
    
    
    '////////////////
    'HELPER ROUTINES:
    '////////////////
    #If  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
    #Else 
        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
    #End  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
    
    
    #If  VBA7 Then
        Private Function GetStrFromPtrW(ByVal Ptr As LongPtr) As String
    #Else 
        Private Function GetStrFromPtrW(ByVal Ptr As Long) As String
    #End  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
    Code:
    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:
    Code:
    Option Explicit
    
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
        bWBClosing = True
    End Sub
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •