Option Explicit
'
Private Const CBS_SIMPLE As Long = &H1&
Private Const CBS_DROPDOWN As Long = &H2&
Private Const CBS_DROPDOWNLIST As Long = &H3&
'
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 Const WH_CBT = 5&
Private Const HC_ACTION = 0&
Private Const HCBT_CREATEWND = 3&
'
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
'
Private Declare Function GetWindowLong _
Lib "user32" _
Alias "GetWindowLongA" (ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
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 GetClassName _
Lib "user32" _
Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
'hook arg vars...
Dim m_hHook As Long
Dim m_ClassName As String
Dim m_StylesAdd As Long, m_StylesRemove As Long
Dim m_ExStylesAdd As Long, m_ExStylesRemove As Long
Dim m_CallNext As Boolean
Dim m_UseExactClassname As Boolean
Public Function AddSimpleCombo(ContainerForm As Form, _
strComboName As String) As ComboBox
If NoControlWithSameName(ContainerForm, strComboName) Then
CbtHookStyle "ThunderComboBox", True, CBS_SIMPLE, CBS_DROPDOWN Or CBS_DROPDOWNLIST, 0, 0, True
Set AddSimpleCombo = ContainerForm.Controls.Add("VB.ComboBox", strComboName)
CbtUnhookStyle
End If
End Function
Public Function AddDropDownCombo(ContainerForm As Form, _
strComboName As String) As ComboBox
If NoControlWithSameName(ContainerForm, strComboName) Then
CbtHookStyle "ThunderComboBox", True, CBS_DROPDOWN, 0, 0, 0, True
Set AddDropDownCombo = ContainerForm.Controls.Add("VB.ComboBox", strComboName)
CbtUnhookStyle
End If
End Function
Public Function AddDropDownList(ContainerForm As Form, _
strComboName As String) As ComboBox
If NoControlWithSameName(ContainerForm, strComboName) Then
CbtHookStyle "ThunderComboBox", True, CBS_DROPDOWNLIST, 0, 0, 0, True
Set AddDropDownList = ContainerForm.Controls.Add("VB.ComboBox", strComboName)
CbtUnhookStyle
End If
End Function
Private Sub CbtHookStyle(sClassname As String, _
Optional ByVal UseExactClassname As Boolean = False, _
Optional ByVal StylesAdd As Long = 0&, _
Optional ByVal StylesRemove As Long = 0&, _
Optional ByVal ExStylesAdd As Long = 0&, _
Optional ByVal ExStylesRemove As Long = 0&, _
Optional ByVal CallNextHook As Boolean = False)
'Sets hook - call just prior to adding control
CbtUnhookStyle 'allow only 1 active at any time
m_ClassName = sClassname
m_StylesAdd = StylesAdd
m_StylesRemove = StylesRemove
m_ExStylesAdd = ExStylesAdd
m_ExStylesRemove = ExStylesRemove
m_CallNext = CallNextHook
m_UseExactClassname = UseExactClassname
m_hHook = SetWindowsHookEx(WH_CBT, AddressOf CbtHook, 0&, App.ThreadID)
End Sub
Private Sub CbtUnhookStyle()
'unhooks - call immediately after adding control
If m_hHook <> 0& Then
UnhookWindowsHookEx m_hHook
m_hHook = 0&
End If
End Sub
Private Function NoControlWithSameName(ContainerForm As Form, _
strComboName As String) As Boolean
On Error GoTo ErrHndlr
Dim ctl As Control
For Each ctl In ContainerForm.Controls
If ctl.Name = strComboName Then
Exit Function
End If
Next
NoControlWithSameName = True
Exit Function
ErrHndlr:
End Function
Private Function CbtHook(ByVal nCode As Long, _
ByVal hwnd As Long, _
ByVal lpCBCT As Long) As Long
Select Case nCode
Case Is < HC_ACTION
CbtHook = CallNextHookEx(m_hHook, nCode, hwnd, ByVal lpCBCT)
Exit Function '===============>>>
Case HCBT_CREATEWND
OnCreate ByVal hwnd
Case Else
'do nothing
End Select
If m_CallNext Then
CbtHook = CallNextHookEx(m_hHook, nCode, hwnd, ByVal lpCBCT)
End If
End Function
Private Sub OnCreate(ByVal hwnd As Long)
Dim L As Long, lRet As Long
Dim sClass As String
Dim bHit As Boolean
sClass = String(256, 0)
lRet = GetClassName(hwnd, sClass, 255&)
If lRet > 0& Then
If m_UseExactClassname Then
'(non case-sens match)
sClass = Left$(sClass, lRet)
bHit = (StrComp(sClass, m_ClassName, vbTextCompare) = 0)
Else
'(fuzzy match)
bHit = (InStr(1, sClass, m_ClassName, vbTextCompare) > 0)
End If
If bHit Then
'make style, exstyle changes...
If (m_StylesAdd Or m_StylesRemove) <> 0& Then
L = GetWindowLong(hwnd, GWL_STYLE)
L = L Or m_StylesAdd
L = L And (Not m_StylesRemove)
SetWindowLong hwnd, GWL_STYLE, L
End If
If (m_ExStylesAdd Or m_ExStylesRemove) <> 0& Then
L = GetWindowLong(hwnd, GWL_EXSTYLE)
L = L Or m_ExStylesAdd
L = L And (Not m_ExStylesRemove)
SetWindowLong hwnd, GWL_EXSTYLE, L
End If
End If 'is class
End If
End Sub