Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,775
- Office Version
- 2016
- Platform
- Windows
Hi all.
I've been digging into the Win API for the last few days in order to create a decent data validation list that imitates the familiar internet search boxes. ie a list that offers handy functionalies such as word-autocompleter as you type in, not displaying duplicate items, sorting.... I 've seen this requested by many people time and time again.
I tried doing this sometime ago using some tricks but the result was shaky at best. Here, I followed a different approach by creating a windows combobox control from scratch and catching all the input messages directed at it. The result I got when applied to a source range "A2:A500" was not bad and no crashing occurred so far.
Anyone interested , I invite them to try this WORKBOOK DEMO here and I would be interest to hear any problems/suggestions from you.
Code:
The following applies the custom data validation list to the input cell D2 whose source list resides in the range A2:A500.
In a Standard module :
In the Worksheet module :
Regards.
I've been digging into the Win API for the last few days in order to create a decent data validation list that imitates the familiar internet search boxes. ie a list that offers handy functionalies such as word-autocompleter as you type in, not displaying duplicate items, sorting.... I 've seen this requested by many people time and time again.
I tried doing this sometime ago using some tricks but the result was shaky at best. Here, I followed a different approach by creating a windows combobox control from scratch and catching all the input messages directed at it. The result I got when applied to a source range "A2:A500" was not bad and no crashing occurred so far.
Anyone interested , I invite them to try this WORKBOOK DEMO here and I would be interest to hear any problems/suggestions from you.
Code:
The following applies the custom data validation list to the input cell D2 whose source list resides in the range A2:A500.
In a Standard module :
Code:
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type Msg
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Declare Function CreateWindowEx Lib "user32" _
Alias "CreateWindowExA" _
(ByVal dwExStyle As Long, _
ByVal lpClassName As String, _
ByVal lpWindowName As String, _
ByVal dwStyle As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hWndParent As Long, _
ByVal hMenu As Long, _
ByVal hInstance As Long, _
lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal nCmdShow 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 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 FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long) 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 ScreenToClient Lib "user32" ( _
ByVal hwnd As Long, _
lpPoint As POINTAPI) As Long
Private Declare Function SendMessage Lib "user32.dll" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) As Long
Private Declare Function SetFocus Lib "user32.dll" _
(ByVal hwnd As Long) As Long
Private Declare Function GetMessage Lib "user32" _
Alias "GetMessageA" _
(lpMsg As Msg, _
ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long) As Long
Private Declare Function TranslateMessage Lib "user32" _
(lpMsg As Msg) As Long
Private Declare Function DispatchMessage Lib "user32" _
Alias "DispatchMessageA" _
(lpMsg As Msg) As Long
Private Declare Function GetFocus Lib "user32.dll" () _
As Long
Private Declare Function MoveWindow Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Private Declare Function WindowFromPoint Lib "user32.dll" _
(ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" _
(ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetQueueStatus Lib "user32" _
(ByVal fuFlags As Long) As Long
Private Declare Function BlockInput Lib "user32.dll" _
(ByVal fBlockIt As Long) As Long
Private Const GWL_WNDPROC As Long = -4
Private Const WM_KEYDOWN = &H100
Private Const WM_MOUSEMOVE As Long = &H200
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_GETTEXT As Long = &HD
Private Const WM_SETCURSOR As Long = &H20
Private Const VK_DOWN As Long = &H28
Private Const CB_GETTOPINDEX As Long = &H15B
Private Const CB_GETLBTEXT As Long = &H148
Private Const CB_RESETCONTENT As Long = &H14B
Private Const CB_FINDSTRING As Long = &H14C
Private Const CB_ADDSTRING As Long = &H143
Private Const CB_ERR As Long = (-1)
Private Const CB_SHOWDROPDOWN As Long = &H14F
Private Const CB_GETDROPPEDSTATE As Long = &H157
Private Const LB_SETCURSEL As Long = &H186
Private Const LB_RESETCONTENT As Long = &H184
Private Const LB_ITEMFROMPOINT As Long = &H1A9
Private Const EM_SETSEL As Long = &HB1
Private Const CBN_SELENDCANCEL As Long = 10
Private Const CBN_EDITCHANGE As Long = 5
Private Const CBN_SELENDOK As Long = 9
Private Const WM_COMMAND As Long = &H111
Private Const WM_CTLCOLORLISTBOX As Long = &H134
Private Const WM_CTLCOLOREDIT As Long = &H133
Private Const WS_EX_WINDOWEDGE As Long = &H100&
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_VSCROLL As Long = &H200000
Private Const WS_BORDER As Long = &H800000
Private Const CBS_SORT As Long = &H100&
Private Const CBS_HASSTRINGS As Long = &H200&
Private Const CBS_DROPDOWN As Long = &H2&
Private Const CBS_NOINTEGRALHEIGHT As Long = &H400&
Private Const MY_COMBO_STYLES = _
(WS_CHILD Or WS_VISIBLE _
Or WS_VSCROLL Or CBS_DROPDOWN Or _
CBS_NOINTEGRALHEIGHT Or _
WS_BORDER Or CBS_SORT Or _
CBS_HASSTRINGS)
Private Const QS_MOUSEBUTTON = &H4
Private Const QS_MOUSEMOVE = &H2
Private Const QS_MOUSE = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const PointsPerInch = 72
Private oInputCell As Range
Private oListSource As Range
Private arList() As Variant
Private lWkbHwnd As Long
Private lAppHwnd As Long
Private lDeskHwnd As Long
Private lListBoxHwnd As Long
Private lCBLBox As Long
Private lCBEditBox As Long
Private lCBBox As Long
Private lPrevWnd As Long
Private lHighlightedItem As Long
Private lCurMsg As Long
Private bXitLoop As Boolean
Private bStopInput As Boolean
Public Sub Test(ByVal InputCell As Range, ByVal ListSource As Range)
Dim tPt1 As POINTAPI
Dim tPt2 As POINTAPI
'===========================
Application.EnableCancelKey = xlDisabled
Set oInputCell = InputCell
Set oListSource = ListSource
lAppHwnd = _
FindWindow("XLMAIN", Application.Caption)
lDeskHwnd = FindWindowEx _
(lAppHwnd, 0, "XLDESK", vbNullString)
lWkbHwnd = FindWindowEx _
(lDeskHwnd, 0, "EXCEL7", vbNullString)
With GetRangeRect(oInputCell)
tPt1.x = .Left
tPt1.y = .Top
tPt2.x = .Right
tPt2.y = .Bottom
End With
ScreenToClient lWkbHwnd, tPt1
ScreenToClient lWkbHwnd, tPt2
lListBoxHwnd = CreateWindowEx(WS_EX_WINDOWEDGE, "ComboBox", _
vbNullString, MY_COMBO_STYLES, tPt1.x, tPt1.y, tPt2.x - tPt1.x, 0 _
, lWkbHwnd, 0, 0, 0)
lCBLBox = FindWindow("ComboLBox", vbNullString)
lCBEditBox = FindWindowEx(lListBoxHwnd, 0, "Edit", vbNullString)
lCBBox = FindWindowEx(lWkbHwnd, 0, "ComboBox", vbNullString)
SetFocus lListBoxHwnd
lPrevWnd = SetWindowLong _
(lWkbHwnd, GWL_WNDPROC, AddressOf CallBackProc)
Call MessageLoop
End Sub
Public Sub TerminateInputValidation()
lHighlightedItem = -1
bXitLoop = True
SetWindowLong _
lWkbHwnd, GWL_WNDPROC, lPrevWnd
DestroyWindow lListBoxHwnd
Application.EnableCancelKey = xlInterrupt
End Sub
Private Sub MessageLoop()
Dim aMsg As Msg
Dim tPt As POINTAPI
Dim tPt1 As POINTAPI
Dim tPt2 As POINTAPI
Static lPrevItem As Long
'===============================
bXitLoop = False
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Do While GetMessage(aMsg, 0, 0, 0) And bXitLoop = False
lCurMsg = aMsg.message
SendMessage lCBEditBox, EM_SETSEL, -1, 0
With GetRangeRect(oInputCell)
tPt1.x = .Left
tPt1.y = .Top
tPt2.x = .Right
tPt2.y = .Bottom
End With
ScreenToClient lWkbHwnd, tPt1
ScreenToClient lWkbHwnd, tPt2
If aMsg.message <> WM_MOUSEMOVE Then
MoveWindow lListBoxHwnd, tPt1.x, tPt1.y, tPt2.x - tPt1.x, 200, 1
If aMsg.message = WM_KEYDOWN And aMsg.wParam = VK_DOWN Then
If GetFocus = lCBEditBox Then
If SendMessage _
(lListBoxHwnd, CB_GETDROPPEDSTATE, 0, 0) = False Then
SendMessage lListBoxHwnd, CB_SHOWDROPDOWN, True, 0
End If
End If
End If
DoEvents
TranslateMessage aMsg
DispatchMessage aMsg
Else
GetCursorPos tPt
If WindowFromPoint(tPt.x, tPt.y) = lCBLBox Then
ScreenToClient lCBLBox, tPt
lHighlightedItem = SendMessage _
(lCBLBox, LB_ITEMFROMPOINT, 0, _
ByVal ((tPt.x * &H10000 + tPt.y And &HFFFF&) * 65536))
If lPrevItem <> lHighlightedItem Then
SendMessage _
lCBLBox, LB_SETCURSEL, lHighlightedItem, 0
End If
lPrevItem = lHighlightedItem
End If
End If
Loop
End Sub
Private Function CallBackProc _
(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lRet1 As Long
Dim lRet2 As Long
Dim lRet3 As Long
Dim lRet4 As Long
Dim sBuffer1 As String
Dim sBuffer2 As String
Dim sBuffer3 As String
Dim sBuffer4 As String
Dim loword As Long
Dim hiword As Long
Dim i As Long
'=========================================
On Error Resume Next
Application.EnableCancelKey = xlDisabled
arList = oListSource
If GetFocus <> lCBEditBox Then
SetFocus lCBEditBox
End If
Select Case Msg
Case WM_CTLCOLORLISTBOX
If SendMessage _
(lListBoxHwnd, CB_GETTOPINDEX, 0, 0) = 1 And _
lCurMsg <> WM_LBUTTONDOWN Then
BlockInput lListBoxHwnd
End If
Case WM_CTLCOLOREDIT
BlockInput 0
Case WM_COMMAND
SendMessage hwnd, WM_SETCURSOR, lListBoxHwnd, 0
GetHiLoword wParam, loword, hiword
sBuffer1 = Space(256)
lRet1 = SendMessage _
(lListBoxHwnd, WM_GETTEXT, Len(sBuffer1), ByVal sBuffer1)
Err.Clear
Application.WorksheetFunction.Match _
Left(sBuffer1, lRet1), arList(), 0
If Err <> 0 Then
bStopInput = True
End If
If Err = 0 And Len(Left(sBuffer1, lRet1)) > 0 Then
bStopInput = False
End If
'populate the listbox.
If lRet1 = 0 Then
For i = 1 To UBound(arList)
If SendMessage _
(lListBoxHwnd, CB_FINDSTRING, -1, _
ByVal (CStr(arList(i, 1)))) = CB_ERR Then
SendMessage lListBoxHwnd, CB_ADDSTRING, 0, _
ByVal (CStr(arList(i, 1)))
End If
Next
End If
If lParam = lListBoxHwnd Then
If hiword = CBN_SELENDOK Then
sBuffer2 = Space(256)
lRet2 = SendMessage _
(lCBEditBox, WM_GETTEXT, Len(sBuffer2), ByVal sBuffer2)
If bStopInput And (GetQueueStatus(QS_MOUSE)) = 0 Then
SetFocus hwnd
MsgBox "Invalid Entry. ", vbCritical
End If
If bStopInput = False And _
(GetQueueStatus(QS_MOUSE)) = 0 Then
oInputCell = Left(sBuffer2, lRet2)
SetFocus hwnd
End If
If lHighlightedItem >= 0 Then
sBuffer3 = Space(256)
lRet3 = SendMessage _
(lListBoxHwnd, CB_GETLBTEXT, _
lHighlightedItem, ByVal sBuffer3)
SetFocus hwnd
oInputCell = Left(sBuffer3, lRet3)
ShowWindow lListBoxHwnd, 0
SendMessage lListBoxHwnd, CB_RESETCONTENT, 0, 0
End If
SetFocus hwnd
End If '\\\ End hiword = CBN_SELENDOK
If hiword = CBN_SELENDCANCEL Then
ShowWindow lListBoxHwnd, 0
TerminateInputValidation
End If
If hiword = CBN_EDITCHANGE Then
SendMessage lCBLBox, LB_RESETCONTENT, 0, 0
sBuffer4 = Space(256)
lRet4 = SendMessage _
(lListBoxHwnd, WM_GETTEXT, Len(sBuffer4), ByVal sBuffer4)
For i = 1 To UBound(arList)
If Len(Left(sBuffer4, lRet4)) >= 0 Then
If SendMessage _
(lListBoxHwnd, CB_GETDROPPEDSTATE, 0, 0) = False Then
SendMessage lListBoxHwnd, CB_SHOWDROPDOWN, True, 0
End If
If UCase(Left(CStr(arList(i, 1)), lRet4)) = _
UCase(Left(sBuffer4, lRet4)) Then
If SendMessage _
(lListBoxHwnd, CB_FINDSTRING, -1, _
ByVal (CStr(arList(i, 1)))) = CB_ERR Then
SendMessage lListBoxHwnd, CB_ADDSTRING, 0, _
ByVal (CStr(arList(i, 1)))
End If
End If
Else
SendMessage lCBLBox, LB_RESETCONTENT, 0, 0
SendMessage lListBoxHwnd, CB_SHOWDROPDOWN, False, 0
SetFocus hwnd
End If
Next
End If ' \\\\\ End hiword = CBN_EDITCHANGE
End If ' \\\\\ End lParam = lListBoxHwnd
End Select
'process other msgs.
CallBackProc = CallWindowProc _
(lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
End Function
Private Function ScreenDPI(bVert As Boolean) As Long
Static lDPI(1), lDc
If lDPI(0) = 0 Then
lDc = GetDC(0)
lDPI(0) = GetDeviceCaps(lDc, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(lDc, LOGPIXELSY)
lDc = ReleaseDC(0, lDc)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / PointsPerInch
End Function
Private Function GetRangeRect(ByVal rng As Range) As RECT
Dim OWnd As Window
Set OWnd = rng.Parent.Parent.Windows(1)
With rng
GetRangeRect.Left = PTtoPX(.Left * OWnd.Zoom / 100, 0) _
+ OWnd.PointsToScreenPixelsX(0)
GetRangeRect.Top = PTtoPX(.Top * OWnd.Zoom / 100, 1) _
+ OWnd.PointsToScreenPixelsY(0)
GetRangeRect.Right = PTtoPX(.Width * OWnd.Zoom / 100, 0) _
+ GetRangeRect.Left
GetRangeRect.Bottom = PTtoPX(.Height * OWnd.Zoom / 100, 1) _
+ GetRangeRect.Top
End With
End Function
Private Sub GetHiLoword _
(lParam As Long, ByRef loword As Long, ByRef hiword As Long)
' this is the LOWORD of the lParam:
loword = lParam And &HFFFF&
' LOWORD now equals 65,535 or &HFFFF
' this is the HIWORD of the lParam:
hiword = lParam \ &H10000 And &HFFFF&
' HIWORD now equals 30,583 or &H7777
End SubIn the Worksheet module :
Code:
Option Explicit
Private Sub Worksheet_BeforeDoubleClick _
(ByVal Target As Range, Cancel As Boolean)
If Target.Address = Range("d2").Address Then
Cancel = True
Call Test(ByVal Target, ByVal Range("A2:A500"))
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = Range("d2").Address Then
Call Test(ByVal Target, ByVal Range("A2:A500"))
Else
Call TerminateInputValidation
End If
End SubRegards.
