'**********************************************************************************
' __ _____ ___ . ___ _____ ___ ___
'|__| /\ | | | | | | / | | | | | | | | |\ |
'| /__\ | |--- | | |/\ | | | | | | | | | \ |
'| / \ | | \ | |___ | \ | |___| |___| |__ |___| | \|
'***********************************************************************************
'module de fonction pour combobox
'1 fonction << GetComboboxDropdownState >> renvoie le status d'un combobox (developpée ou pas )
'2 fonction << GetComboboxChildRectangle >> renvoie une variable rect (le rectangle en pixel de la fenetre child de la combobox )
'version: beta
'date version:28/10/2022
'Auteur:Patricktoulon
'un userform de test l'accompagne
'les fonction sont appelée dans le le mouseup du control
'ce qui implique que le dropdown_click appelle aussi
'par contre le click dans la fentre child non
'j'ai fait comme ça pour limiter l'appel seulement quand la combobox n'est pas développée
'seul le click sur le dropdownbutton agit et appelle les fonctions (MEME SI LES APPELS SONT DANS LE MOUSEUP!!!)
'**********************************************************************************
#If VBA7 Then
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
#Else
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
#End If
Private Type POINTAPI: X As Long: Y As Long: End Type
Type RECT: Left As Long: Top As Long: Right As Long: Bottom As Long: End Type
'Donne le status de la combobox( developpée ou pas)--->boolean
Function GetComboboxDropdownState(ByVal combo As msforms.ComboBox) As Boolean
Dim r As RECT: r = GetComboboxChildRectangle(combo)
GetComboboxDropdownState = r.Left > 0
End Function
'fonction qui renvoie une variable de type rect ce rect contient les points de la fenetre child de la combobox
Function GetComboboxChildRectangle(ByVal combo As msforms.ComboBox) As RECT
Dim pos As POINTAPI, rct As RECT, H1&, H2&, ppx#
ppx = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72
H1 = GetFocus
GetCursorPos pos
H2 = WindowFromPoint(pos.X, pos.Y + combo.Height * ppx)
If H1 <> H2 Then GetWindowRect H2, rct
'a fin d'inclure la partie rectangle du combobox lui meme dans le rectangle on l'enleve du rct.top
rct.Top = rct.Top - (combo.Height * ppx)
If rct.Left = 0 Then rct.Top = 0
GetComboboxChildRectangle = rct ' H1 <> H2
End Function
.
