Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
Hi dear forum members,
As the title says, I have written this code in order to allow the widening of comboboxes dropdowns without the need to make the actual combobox wider.
In order to get the most accurate results, the value of the Const : "TUNING_SCALE_CONSTANT" declared at the top of the 'API _bas' module may need to be adjusted according to the currrent Worksheet zoom, the combo Font Size etc ...
Try experimenting with that constant until you find the satisfactory value that works best for the current zoom, font size etc ..
BTW, I am referring here to ComboBoxes embedeed in worksheets not on UserForms.
Workbook example
1- Api based code in a Standard Module :
2- Code Usage in the Worksheet Module:
I hope you will find this useful.
As the title says, I have written this code in order to allow the widening of comboboxes dropdowns without the need to make the actual combobox wider.
In order to get the most accurate results, the value of the Const : "TUNING_SCALE_CONSTANT" declared at the top of the 'API _bas' module may need to be adjusted according to the currrent Worksheet zoom, the combo Font Size etc ...
Try experimenting with that constant until you find the satisfactory value that works best for the current zoom, font size etc ..
BTW, I am referring here to ComboBoxes embedeed in worksheets not on UserForms.
Workbook example
1- Api based code in a Standard Module :
Code:
Option Explicit
Private Type Size
cx As Long
cy As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
[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
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Private Type CWPSTRUCT
lParam As LongPtr
wParam As LongPtr
message As Long
hwnd As LongPtr
End Type
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
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 GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, lpdwProcessId As Long) As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As LongPtr, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) 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 GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
Private hHook As LongPtr, hPrevWndProc As LongPtr, hDropDownHwnd As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Type CWPSTRUCT
lParam As Long
wParam As Long
message As Long
hwnd As Long
End Type
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) 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 GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function CallWindowProc Lib "user32" 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 GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private hHook As Long, hPrevWndProc As Long, hDropDownHwnd As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Private Const WH_CALLWNDPROC = 4
Private Const WM_CREATE = &H1
Private Const GWL_WNDPROC = (-4)
Private Const WM_PAINT = &HF
Private Const GWL_STYLE As Long = -16
Private Const SWP_NOMOVE = &H2
Private Const SWP_SHOWWINDOW = &H40
[B][COLOR=#008000]'==================================================[/COLOR][/B]
[B][COLOR=#008000]' IMPORTANT !! '[/COLOR][/B]
[B][COLOR=#008000]'============== '[/COLOR][/B]
[B][COLOR=#008000]' Experiment with the value of this Const value until you find' '[/COLOR][/B]
[B][COLOR=#008000]' the satifactory value for the current zoom, Font size etc ... '[/COLOR][/B]
Private Const TUNING_SCALE_CONSTANT = 50
[B][COLOR=#008000]'==================================================[/COLOR][/B]
Private oCombo As Object
Private vArrList() As Variant
Public Sub AllowDropDownWidening(ByVal ComboBox As Object)
Set oCombo = ComboBox
vArrList() = Application.Transpose(ComboBox.List)
If IsWindowVisible(hDropDownHwnd) Then Exit Sub
Call UnhookWindowsHookEx(hHook)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
hHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookFunction, Application.HinstancePtr, GetWindowThreadProcessId(Application.hwnd, 0))
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
hHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookFunction, Application.Hinstance, GetWindowThreadProcessId(Application.hwnd, 0))
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
End Sub
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
Private Function HookFunction(ByVal ncode As Long, ByVal wParam As LongPtr, lParam As CWPSTRUCT) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Function HookFunction(ByVal ncode As Long, ByVal wParam As Long, lParam As CWPSTRUCT) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Dim strClass As String
On Error Resume Next
If lParam.message = WM_CREATE Then
hDropDownHwnd = lParam.hwnd
strClass = Space(255)
strClass = Left(strClass, GetClassName(lParam.hwnd, ByVal strClass, 255))
If InStr(1, strClass, "F3 Server") Then
Call UnhookWindowsHookEx(hHook)
hPrevWndProc = SetWindowLong(lParam.hwnd, GWL_WNDPROC, AddressOf SubClassFunction)
End If
End If
HookFunction = CallNextHookEx(hHook, ncode, wParam, ByVal lParam)
End Function
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
Private Function SubClassFunction(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim lStyle As LongPtr, hdc As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Function SubClassFunction(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lStyle As Long, hdc As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Dim tRect As RECT, tTextSize As Size
Dim strClass As String * 256, lret As Long
Dim lWidth As Long, i As Long
On Error Resume Next
Select Case Msg
Case WM_PAINT
lret = GetClassName(hwnd, strClass, 256)
lStyle = GetWindowLong(hwnd, GWL_STYLE)
If lStyle = 1442840576 Then
hdc = GetDC(0)
GetWindowRect (hwnd), tRect
For i = 1 To UBound(vArrList)
Call GetTextExtentPoint32(hdc, vArrList(i), Len(vArrList(i)), tTextSize)
If lWidth <= tTextSize.cx Then lWidth = tTextSize.cx
Next i
ReleaseDC 0, hdc
lWidth = (lWidth + TUNING_SCALE_CONSTANT) * (ActiveWindow.Zoom / 100)
If oCombo.Width < lWidth Then
SetWindowPos GetParent(hwnd), 0, 0, 0, lWidth, tRect.Bottom - tRect.Top, SWP_NOMOVE + SWP_SHOWWINDOW
End If
Call SetWindowLong(hwnd, GWL_WNDPROC, hPrevWndProc)
Exit Function
End If
End Select
SubClassFunction = CallWindowProc(hPrevWndProc, hwnd, Msg, wParam, ByVal lParam)
End Function
2- Code Usage in the Worksheet Module:
Code:
Option Explicit
Private Sub ComboBox1_DropButt*******()
Call AllowDropDownWidening(Me.ComboBox1)
End Sub
Private Sub ComboBox2_DropButt*******()
Call AllowDropDownWidening(Me.ComboBox2)
End Sub
I hope you will find this useful.