Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,616
- Office Version
- 2016
- Platform
- Windows
I recently developped this new code that is supposed to add a word-autocomplete feature to a designated input cell so that ,as you start typing the words into the cell , a dropdown automatically pops up suggesting a list of matches. Excellent for long lists . It also works ( to a certain extent) as an input validating feature.
I developped and tested the code in Excel 2003 Win XP SP2 only. I don't know how or if it will work on other versions . Please let me know if this is stable enough if you try it.
Note: In order to make the code as stable as possible,the workbook brievly makes use of the VBE object model upon opening , therefore we need to trust access to the VB project by going to :
Tools> Macro> Security>Trusted Publishers>Trust Access To Visual Basic Project >OK
Workbook example.
1- Code in ThisWorkbook module.
2- Code in the sheet module ( the sheet where the list and input cell are located)
3- Code in a Standard Module :
I developped and tested the code in Excel 2003 Win XP SP2 only. I don't know how or if it will work on other versions . Please let me know if this is stable enough if you try it.
Note: In order to make the code as stable as possible,the workbook brievly makes use of the VBE object model upon opening , therefore we need to trust access to the VB project by going to :
Tools> Macro> Security>Trusted Publishers>Trust Access To Visual Basic Project >OK
Workbook example.
1- Code in ThisWorkbook module.
Code:
Option Explicit
Private Sub Workbook_Open()
Application.Goto Me.ActiveSheet.Cells(1, 1), True
Call PlaySafeHooking
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not bXitLoop Then
Call TerminateInputValidation
End If
End Sub
Private Sub Workbook_Activate()
Application.Goto Me.ActiveSheet.Cells(1, 1), True
End Sub
Private Sub Workbook_Deactivate()
If Not bXitLoop Then
Call TerminateInputValidation
End If
End Sub
Private Sub PlaySafeHooking()
Dim wb As Workbook
SendMessage GetDesktopWindow, WM_SETREDRAW, ByVal 0, 0&
Set wb = Workbooks.Add
wb.Windows(1).Visible = False
wb.Close False
With Application.VBE.CommandBars
.FindControl(ID:=189).Execute 'stop ctl
.FindControl(ID:=228).Execute 'reset ctl
.FindControl(ID:=106).Execute 'back to xl ctl
End With
Application.OnTime Now, Me.CodeName & ".HideTheVBE"
End Sub
Private Sub HideTheVBE()
Application.VBE.MainWindow.Visible = False
SendMessage GetDesktopWindow, WM_SETREDRAW, ByVal 1, 0&
End Sub2- Code in the sheet module ( the sheet where the list and input cell are located)
Code:
Option Explicit
'Apply Custom Validation to Cell D2.
Private Sub Worksheet_BeforeDoubleClick _
(ByVal Target As Range, Cancel As Boolean)
If Target.Address = Range("D2").Address Then
Cancel = True
Call ApplyCustomValidation _
(ByVal Target, ByVal Me.Range("A2:A100"))
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = Range("D2").Address Then
Call ApplyCustomValidation _
(ByVal Target, ByVal Me.Range("A2:A100"))
Else
Call TerminateInputValidation
End If
End Sub
Private Sub Worksheet_Activate()
Application.Goto Me.Cells(1, 1), True
End Sub
Private Sub Worksheet_Deactivate()
Call TerminateInputValidation
End Sub3- Code in a Standard Module :
Code:
Option Explicit
'\\Public Declarations.
Public Declare Function GetDesktopWindow Lib _
"user32.dll" () As Long
Public 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
Public Const WM_SETREDRAW As Long = &HB
Public bXitLoop As Boolean
Public oInputCell As Range
'\\Private Declarations.
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 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 WM_DESTROY As Long = &H2
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 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 bStopInput As Boolean
Public Sub ApplyCustomValidation(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()
SetFocus lAppHwnd
lHighlightedItem = -1
DestroyWindow lListBoxHwnd
bXitLoop = True
SetWindowLong _
lWkbHwnd, GWL_WNDPROC, lPrevWnd
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
If GetFocus <> lCBEditBox Then
Call TerminateInputValidation
Exit Sub
End If
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
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
Call TerminateInputValidation
Call ApplyCustomValidation _
(ByVal oInputCell, ByVal oListSource)
End If
If bStopInput = False And _
(GetQueueStatus(QS_MOUSE)) = 0 Then
oInputCell = Left(sBuffer2, lRet2)
oInputCell.Offset(1).Select
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)
oInputCell.Offset(1).Select
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
Case Is = WM_DESTROY
Call TerminateInputValidation
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 Sub
Last edited:
