Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- Windows
Hi all,
Here is an improvement on the last AutoWordCompleter i posted recently. See here an example of the new improved Class : http://www.savefile.com/files/1239800
You just need to declare the Class and simply set it's properties as shown below and the Class will find all the matching list items for you dinamically as you type in the input cell saving you time and syntax errors. Ideal for long lists.
I overcame the problem caused by fast typing by temporarly setting the keyboard focus to a hidden ListView control added at runtime . Because of this, the code may fail when attempting to add the ListView control depending on the Office version. I am curious to find out if it works for other than Office XP.
here is the Class code for the record: (cAutoWordCompleter)
Acouple of things :
1 - If the custom blinking cursor is ill-placed over the inputcell text or placed too far you can easily adjust it by changing the value of the constante OffsetPixels located in the main routine ProcessKeyStrokes.
2 - The ws Zoom must be set to 100 for the class to work properly otherwise the listbox gets disproportioned.
I am curious to know if this works for other than Office XP because of the ListView Control added at runtime so I would appreciate any feedback on this.
Regards.
Here is an improvement on the last AutoWordCompleter i posted recently. See here an example of the new improved Class : http://www.savefile.com/files/1239800
You just need to declare the Class and simply set it's properties as shown below and the Class will find all the matching list items for you dinamically as you type in the input cell saving you time and syntax errors. Ideal for long lists.
Code:
Private AutoWordCompleter As cAutoWordCompleter
Sub StarttheAutoCompleter()
If AutoWordCompleter Is Nothing Then
Set AutoWordCompleter = New cAutoWordCompleter
With AutoWordCompleter
Set .InputCell = Range("d3")
Set .SearchList = Range("a4:a2600")
.FormatInputCell = False
.Execute
End With
Else
MsgBox "The AutoWordCompleter is already running.", vbInformation
End If
End Sub
Sub TerminateTheAutoCompleter()
If Not AutoWordCompleter Is Nothing Then
AutoWordCompleter.DestroyMe
Set AutoWordCompleter = Nothing
Else
MsgBox "The AutoCompleter is already terminated.", vbInformation
End If
End SubI overcame the problem caused by fast typing by temporarly setting the keyboard focus to a hidden ListView control added at runtime . Because of this, the code may fail when attempting to add the ListView control depending on the Office version. I am curious to find out if it works for other than Office XP.
here is the Class code for the record: (cAutoWordCompleter)
Code:
Option Explicit
'_____________________________________
Private WithEvents ListBoxEvents As MSForms.ListBox
Private WithEvents wsEvents As Worksheet
Private P_InputCell As Range
Private P_SearchList As Range
Private P_FormatInputCell As Boolean
'_______________________________________________
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg 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 SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private lHwnd As Long
'__________________________________________
Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" _
(ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32.dll" Alias _
"CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32.dll" _
(ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32.dll" Alias _
"GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, _
ByVal cbString As Long, lpSize As POINTAPI) As Long
Private Declare Function MulDiv Lib "kernel32.dll" _
(ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
End Type
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const PointsPerInch = 72
Private lnghDC As Long
'___________________________________________
Private Declare Function CreateCaret Lib "user32" _
(ByVal hwnd As Long, ByVal hBitmap As Long, _
ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function ShowCaret Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetCaretPos Lib "user32" _
(ByVal x As Long, ByVal Y As Long) As Long
Private Declare Function HideCaret Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DestroyCaret Lib "user32.dll" () As Long
Private Declare Function ScreenToClient Lib "user32" ( _
ByVal hwnd As Long, _
lpPoint As POINTAPI) As Long
Private Declare Function SetCursorPos Lib "user32.dll" ( _
ByVal x As Long, ByVal Y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long
'__________________________________________
Private Declare Function WaitMessage Lib "user32" () As Long
Private Declare Function TranslateMessage Lib "user32" _
(ByRef lpMsg As MSG) As Long
Private Declare Function PeekMessage Lib "user32" _
Alias "PeekMessageA" _
(ByRef lpMsg As MSG, ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long
Private Const WM_KEYDOWN = &H100
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_CHAR As Long = &H102
Private Const PM_REMOVE As Long = &H1
Private Const PM_NOREMOVE = &H0
Private Const PM_NOYIELD As Long = &H2
Private msgMessage As MSG
Private Type POINTAPI
x As Long
Y 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 IsCharAlphaNumeric Lib "user32" _
Alias "IsCharAlphaNumericA" (ByVal cChar As Byte) As Long
Private Const VK_UP = &H26
Private Const VK_DOWN = &H28
Private Const VK_RIGHT = &H27
Private Const VK_LEFT = &H25
Private Const VK_SHIFT = &H10
Private Const VK_BACK = &H8
Private Const VK_ESCAPE = &H1B
Private Const VK_DELETE = &H2E
Private Const VK_SPACE = &H20
Private Const VK_ENTER = &HD
Private oHiddenWs As Worksheet
Private oSearchListCopyRange As Range
Private oCriteriaRange As Range
Private oCopyToRange As Range
Private oListBox
Private oListView
Private bCancelLoop As Boolean
Private bInputCellToBeRefreshed As Boolean
Private bInCellEdit As Boolean
Private bClassTerminatedProperly As Boolean
Private bEnterKeyPressed As Boolean
Private bAutoCompleteOn As Boolean
Private bListBoxClicked As Boolean
Private bListBoxActivated As Boolean
Private Sub ProcessKeyStrokes()
'adjust the value of this const to suit the
'machine screen resolution.
Const OffsetPixels = 3
Dim Message As MSG
Dim oRange As Object
Dim tPoint As POINTAPI
Dim sTempText As String
Dim sOddStrings As String
Dim lResult As Long
'prevent user from interrupting the loop.
Application.EnableCancelKey = xlDisabled
'store the app hwnd in a module level var.
lHwnd = FindWindow("XLMAIN", Application.Caption)
'hook our inputcell worksheet events.
Set wsEvents = P_InputCell.Parent
'create a custom blinkikg cursor.
CreateCaret lHwnd, 0, 1, 15
'store these initial settings in wb names
'so they can be restored should the class
'go out of scope before the propper cleanup !
With Names
.Add "ActiveWsName", P_InputCell.Parent.Name
.Add "InputCellAddress", P_InputCell.Address(False, False)
On Error Resume Next
If Names("InputCellInitialColor") Is Nothing And _
Names("IncellEditingStatus") Is Nothing Then
.Add "InputCellInitialColor", P_InputCell.Interior.ColorIndex
.Add "IncellEditingStatus", Application.EditDirectlyInCell
End If
On Error GoTo 0
End With
'dont clear the inputcell if value is entered from the lbx.
If Not bListBoxClicked Then P_InputCell.ClearContents
RefreshInputCell P_InputCell
P_InputCell.Activate
'give our inputcell a diff color so it stands out.
If P_FormatInputCell Then P_InputCell.Interior.ColorIndex = 35 ' pale green.
'in-cell editing in the inputcell can cause probs
'so let's disable it temporarly.
Application.EditDirectlyInCell = False
'add a listbox to show the filtered list.
On Error Resume Next
If oListBox Is Nothing Then
Call CreateListBox
End If
On Error GoTo 0
'add a hidden dummy listView to get the keyboard focus.
'this is very important to avoid crashing the program
'when fast typing !!!!!!
On Error Resume Next
If oListView Is Nothing Then
Call CreateListViewControl
End If
On Error GoTo 0
'setup advanced filter ranges in
'a newly added hidden sheet.
If Not bAutoCompleteOn Then
SetUpSearchAndFilteredLists
bAutoCompleteOn = True
End If
'start watching for user keystrokes.
Do While Not bCancelLoop
'ignore keystroke procesing outside our inputcell.
If ActiveCell.Address = P_InputCell.Address Then
'wait for a message.
WaitMessage
'check for left-mouse button clicks.
If PeekMessage(Message, lHwnd, WM_LBUTTONDOWN, WM_LBUTTONDOWN, PM_NOREMOVE) Then
'store the mouse pointer pos.
GetCursorPos tPoint
On Error Resume Next
Set oRange = Application.ActiveWindow.RangeFromPoint(tPoint.x, tPoint.Y)
'hide the listbox if the mouse cursor is not over
'the input cell or listbox.
If oRange.Address <> P_InputCell.Address Then
If oRange.Name <> "AutoCompleterLB" And _
GetFocus <> GetListBoxHwnd Then
If oListBox.Visible Then oListBox.Visible = False
End If
End If
On Error GoTo 0 '''
End If
'check if it's a WM_KEYDOWN message.
If PeekMessage(Message, lHwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
'show and redimension the listview control here.
With oListView
If .Visible = False Then
Application.ScreenUpdating = False
.Visible = True
.ShapeRange.Width = 0.1
.ShapeRange.Height = 0.1
.Left = P_InputCell.Left ''
Application.ScreenUpdating = True
End If
'temporarly move the keyboard focus from
'the inputcell to the listview control.
SetFocus .Object.hwnd
End With
'translate the virtual key code to a character.
lResult = TranslateMessage(Message)
'Check which char is in the mssg queu
lResult = PeekMessage(Message, lHwnd, WM_CHAR, _
WM_CHAR, PM_REMOVE + PM_NOYIELD)
'refresh the inputcell before processing the char messages.
If bInputCellToBeRefreshed Then bInputCellToBeRefreshed = False: _
P_InputCell.ClearContents: HideListBox
ShowCaret lHwnd
'let's process the char messages here.
Select Case Message.wParam
Case Is = VK_BACK
'clear everything when inputcell is empty.
If Len(P_InputCell) <= 1 Then
P_InputCell.ClearContents
oListBox.Visible = False
AdjustCaretPos P_InputCell, OffsetPixels
GoTo ResumeLoop
End If
'otherwise, update the input cell value.
P_InputCell = Mid(P_InputCell, 1, Len(P_InputCell) - 1)
'move the cursor to the new last char in the inputcell.
AdjustCaretPos P_InputCell, OffsetPixels
'refresh advanced filter ranges in the hidden ws.
On Error Resume Next
oCriteriaRange.ClearContents
oCopyToRange.ClearContents
On Error GoTo 0
Set oCriteriaRange = oHiddenWs.Range("F1:F2")
oCriteriaRange(1) = oSearchListCopyRange(1).Value
oCriteriaRange(2) = P_InputCell & "*"
'do the filtering now
Set oCopyToRange = _
oSearchListCopyRange(oSearchListCopyRange.Rows.Count).Offset(4)
oSearchListCopyRange.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=oCriteriaRange, CopyToRange:=oCopyToRange, Unique:=True
'if no match found, clear everything and wait for the next keystroke.
If Len(oCopyToRange(2)) = 0 Then
oListBox.Visible = False
AdjustCaretPos P_InputCell, OffsetPixels
GoTo ResumeLoop
Else
oListBox.Visible = True
AdjustCaretPos P_InputCell, OffsetPixels
End If
'otherwise, populate the listbox with the filtered list.
Set oCopyToRange = Range(oCopyToRange.CurrentRegion(2), oCopyToRange.CurrentRegion.End(xlDown))
oListBox.ListFillRange = oHiddenWs.Name & "!" & oCopyToRange.Address
'this is to avoid crashing the app
'when navigating the listbox with
'the arrow keys !!!
Application.SendKeys " "
Application.SendKeys ("BS")
Case Is = VK_ESCAPE
'clear everything if Esc/Del are pressed.
HideListBox
P_InputCell.ClearContents
Case Is = VK_DELETE
HideListBox
P_InputCell.ClearContents
'deselect the inputcell and hide
'the listbox if the keys Left/Right are hit.
Case Is = VK_RIGHT
P_InputCell.Offset(, 1).Select
ClearInvalidEntries
Case Is = VK_LEFT
P_InputCell.Offset(, -1).Select
ClearInvalidEntries
Case Is = VK_UP
On Error Resume Next
If bListBoxActivated Then
Call KeyUpProc
Else
' HideListBox
P_InputCell.Offset(-1).Select
ClearInvalidEntries
End If
Case Is = VK_DOWN
On Error Resume Next
If oListBox.Visible Then
Call ActivateListBox
Call KeyDownProc
Else
P_InputCell.Offset(1).Select
ClearInvalidEntries
End If
'if the listbox is activated update
'the inputcell with the selected lisbox item.
Case Is = VK_ENTER
If bListBoxActivated Then
P_InputCell = oListBox.Object.Value
HideListBox
RefreshInputCell P_InputCell
Else
HideListBox
End If
P_InputCell.Offset(1).Select
'ClearInvalidEntries
End Select
'store a bunch of some usual non alphanumeric chars.
sOddStrings = ",;:!<>-_@=+*-/?}{\^][#~`"
'if the key hit is alphanumeric.
If IsCharAlphaNumeric(Message.wParam) Or Message.wParam = VK_SPACE _
Or InStr(1, sOddStrings, Chr(Message.wParam)) > 0 Then
'update inputcell value.
P_InputCell = P_InputCell & Chr(Message.wParam)
'move cursor to the last char.
AdjustCaretPos P_InputCell, OffsetPixels
'refresh our advanced filter ranges.
On Error Resume Next
oCriteriaRange.ClearContents
oCopyToRange.ClearContents
On Error GoTo 0
'update the advanced filter ranges.
Set oCriteriaRange = oHiddenWs.Range("F1:F2")
oCriteriaRange(1) = oSearchListCopyRange(1).Value
oCriteriaRange(2) = P_InputCell & "*"
Set oCopyToRange = oSearchListCopyRange _
(oSearchListCopyRange.Rows.Count).Offset(4)
'do the filtering now.
oSearchListCopyRange.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=oCriteriaRange, CopyToRange:=oCopyToRange, Unique:=True
'if no matches found hide lisbox and wait for next char.
If Len(oCopyToRange(2)) = 0 Then Set oCopyToRange = Nothing: _
oListBox.Visible = False: GoTo ResumeLoop
Set oCopyToRange = Range(oCopyToRange.CurrentRegion(2), _
oCopyToRange.CurrentRegion.End(xlDown))
'otherwise, populate the listbox with the filered list.
oListBox.ListFillRange = oHiddenWs.Name & "!" & oCopyToRange.Address
'show the updated listbox
oListBox.Visible = True
End If 'end of IsCharAlphaNumeric.
End If 'end of PeekMessage WM_LBUTTONDOWN.
End If 'end of ActiveCell.Address = P_InputCell.Address.
ResumeLoop:
'let the os process other mssgs.
DoEvents
Loop
End Sub
Private Sub StopKeyProcessing()
On Error Resume Next
'reset flags.
bCancelLoop = True
bAutoCompleteOn = False
bClassTerminatedProperly = True
'delete the hidden sheet.
Application.DisplayAlerts = False
oHiddenWs.Delete
Application.DisplayAlerts = True
Set oHiddenWs = Nothing
'delete the listbox.
oListBox.ShapeRange.Delete
Set oListBox = Nothing
'delete the listView.
oListView.ShapeRange.Delete
Set oListView = Nothing
DestroyCaret
'clear inputcell.
RefreshCaret P_InputCell
P_InputCell.ClearContents
'store inputcell initial color.
P_InputCell.Interior.ColorIndex = Evaluate("InputCellInitialColor")
'restore initial in-cell editing value.
Application.EditDirectlyInCell = Evaluate("IncellEditingStatus")
'we have cleaned-up and reset our initial settings
'from the wk names so let's delete them.
Names("ActiveWsName").Delete
Names("InputCellAddress").Delete
Names("InputCellInitialColor").Delete
Names("IncellEditingStatus").Delete
On Error GoTo 0
End Sub
'************************Supporting Routines ************
Private Function GetTextSize(text As String, font As Object) As POINTAPI
Dim tempDC As Long
Dim tempBMP As Long
Dim f As Long
Dim lf As LOGFONT
Dim textSize As POINTAPI
' Create a device context and a bitmap that can be used to store a
' temporary font object.
tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0)
tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)
' Assign the bitmap to the device context.
DeleteObject SelectObject(tempDC, tempBMP)
' Set up the LOGFONT structure and create the font.
lf.lfFaceName = font.Name & Chr$(0)
lf.lfHeight = -MulDiv(font.SIZE, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72)
lf.lfItalic = font.Italic
lf.lfStrikeOut = font.Strikethrough
'lf.lfUnderline = font.Underline
If font.Bold Then lf.lfWeight = 800 Else lf.lfWeight = 400
f = CreateFontIndirect(lf)
' Assign the font to the device context.
DeleteObject SelectObject(tempDC, f)
' Measure the text, and return it into the textSize SIZE structure.
GetTextExtentPoint32 tempDC, text, Len(text), textSize
' Clean up.
DeleteObject f
DeleteObject tempBMP
DeleteDC tempDC
' Return the measurements.
GetTextSize = textSize
End Function
'function needed to set the horz caret position.
Private Function PointsToClientPixelsX(x As Long) As Long
Dim tScreen As POINTAPI
Dim PointsToScrPixelsX As Long
lnghDC = GetDC(0)
PointsToScrPixelsX = ActiveWindow.PointsToScreenPixelsX(x * _
(GetDeviceCaps(lnghDC, LOGPIXELSX) / PointsPerInch * ActiveWindow.Zoom / 100))
tScreen.x = PointsToScrPixelsX
ScreenToClient lHwnd, tScreen
ReleaseDC 0, lnghDC
PointsToClientPixelsX = tScreen.x
End Function
'function needed to set the ver caret position.
Private Function PointsToClientPixelsY(Y As Long) As Long
Dim tScreen As POINTAPI
Dim PointsToScrPixelsY As Long
lnghDC = GetDC(0)
PointsToScrPixelsY = ActiveWindow.PointsToScreenPixelsY(Y * _
(GetDeviceCaps(lnghDC, LOGPIXELSY) / PointsPerInch * ActiveWindow.Zoom / 100))
tScreen.Y = PointsToScrPixelsY
ScreenToClient lHwnd, tScreen
ReleaseDC 0, lnghDC
PointsToClientPixelsY = tScreen.Y
End Function
Private Sub AdjustCaretPos(r As Range, OffsetPixels As Long)
Dim tSize As POINTAPI
Dim tScreen As POINTAPI
Dim sTempText As String
tSize = GetTextSize(r.text, r.font)
ScreenToClient lHwnd, tSize
tScreen.x = PointsToClientPixelsX(r.Left)
tScreen.Y = PointsToClientPixelsY(r.Offset(1).Top)
SetCaretPos tScreen.x + tSize.x + OffsetPixels, tScreen.Y - 15 - 3
ShowCaret (lHwnd)
Call RefreshCaret(r)
End Sub
'needed to refresh the caret.
Private Sub RefreshCaret(r As Range)
Dim sTempText
sTempText = (r)
r.ClearContents
r = sTempText
End Sub
Private Sub RefreshInputCell(r As Range)
RefreshCaret r
HideCaret lHwnd
End Sub
Private Sub HideListBox()
oListBox.Visible = False
HideCaret lHwnd
End Sub
Private Sub ClearInvalidEntries()
Dim iMatchPos As Integer
On Error Resume Next
iMatchPos = WorksheetFunction.Match(P_InputCell, P_SearchList, 0)
If Len(P_InputCell) = 0 Then Exit Sub
If Err <> 0 Then '
MsgBox "Invalid Entry ! ", vbCritical
P_InputCell.ClearContents
End If
End Sub
Private Sub SetUpSearchAndFilteredLists()
'arbitrary row # where the sorted list
'in the hidden worksheet begins.
Const lTargetRow As Long = 5
On Error Resume Next
Application.ScreenUpdating = False
'add new hidden sheet.
Set oHiddenWs = Sheets.Add
With oHiddenWs
.Visible = xlSheetHidden
.Name = "AutoCompleterWS"
Set oSearchListCopyRange = .Cells(lTargetRow, 1)
End With
'copy the search list onto the hidden sheet.
P_SearchList.Offset(-1).Resize(P_SearchList.Rows.Count + 1).Copy _
oSearchListCopyRange
'sort the copied list.
oSearchListCopyRange.Sort oSearchListCopyRange(1) _
, Order1:=xlAscending, Header:=xlGuess
'adjust the copied list size to include all the sorted cells.
Set oSearchListCopyRange = _
oSearchListCopyRange.Resize(P_SearchList.Rows.Count, 1)
Application.ScreenUpdating = True
End Sub
Private Function GetListBoxHwnd() As Long
With GetRangeCenterPointInPixels(P_InputCell.Offset(1))
GetListBoxHwnd = WindowFromPoint(.x, .Y)
End With
End Function
'function needed to get the lisbox hwnd.
Private Function GetRangeCenterPointInPixels(rng As Range) As POINTAPI
Dim CenterX, CenterY As Double
lnghDC = GetDC(0)
CenterX = rng.Left + (rng.Width / 2)
CenterY = rng.Top + (rng.Height / 2)
With GetRangeCenterPointInPixels
.x = ActiveWindow.PointsToScreenPixelsX((CenterX) * _
(GetDeviceCaps _
(lnghDC, LOGPIXELSX) / PointsPerInch * ActiveWindow.Zoom / 100))
.Y = ActiveWindow.PointsToScreenPixelsY((CenterY) * _
(GetDeviceCaps _
(lnghDC, LOGPIXELSY) / PointsPerInch * ActiveWindow.Zoom / 100))
End With
'cleanup
ReleaseDC 0, lnghDC
End Function
'could find no other way to activate the listbox programatically.
Private Sub ActivateListBox()
SendMessage GetListBoxHwnd, WM_LBUTTONDOWN, 0, 0
End Sub
Private Sub CreateListBox()
'adjust this const value to set the lbx height
Const dListBoxHeightFactor = 3
Application.ScreenUpdating = False
Set oListBox = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ListBox.1")
'set listbox properties.
With oListBox
.Name = "AutoCompleterLB"
.Visible = False
.ListFillRange = P_SearchList.Address
.Top = P_InputCell.Offset(1).Top
.Left = P_InputCell.Left
.Width = P_InputCell.Width
.Height = P_InputCell.Height * dListBoxHeightFactor
.Object.SpecialEffect = fmSpecialEffectEtched
.Object.BackColor = P_InputCell.Interior.Color
End With
Application.ScreenUpdating = True
'hook the listbox events here.
Set ListBoxEvents = oListBox.Object
End Sub
Private Sub CreateListViewControl()
'add a hidden ListView control.
Set oListView = P_InputCell.Parent.OLEObjects.Add _
(ClassType:="MSComctlLib.ListViewCtrl.2", _
Left:=P_InputCell.Offset(, Columns.Count - 10).Left, Top:=P_InputCell.Top, _
Width:=0.1, Height:=0.1)
oListView.Visible = False
oListView.Name = "AutoCompleterLV"
End Sub
Private Sub KeyDownProc()
Select Case oListBox.Object.ListIndex
Case Is = -1
oListBox.Object.Selected(0) = True
Case Is = oListBox.Object.ListCount - 1
oListBox.Object.Selected(0) = True
Case Else
oListBox.Object.Selected(oListBox.Object.ListIndex + 1) = True
End Select
End Sub
Private Sub KeyUpProc()
Select Case oListBox.Object.ListIndex
Case Is = 0
oListBox.Object.Selected(oListBox.Object.ListCount - 1) = True
Case Else
oListBox.Object.Selected(oListBox.Object.ListIndex - 1) = True
End Select
End Sub
Private Sub ListBoxEvents_Change()
'reset the flag.
bListBoxActivated = True
End Sub
Private Sub ListBoxEvents_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
'place the selected lisbox item
'into the inputcell upon clicking.
P_InputCell = oListBox.Object.Value
RefreshInputCell P_InputCell
bListBoxClicked = True
P_InputCell.Select
oListBox.Visible = False
'watch for the next keystroke.
Call ProcessKeyStrokes
End Sub
Private Sub ListBoxEvents_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Const ApproxListItemHeight = 16
Dim lindx As Long
Dim dTp As Double
Dim tPoint2 As POINTAPI
On Error Resume Next
'store the mouse pos.
GetCursorPos tPoint2
'store the top screen coordinate of the listbox in pixels.
dTp = Application.ActiveWindow.PointsToScreenPixelsY(oListBox.Top)
'select the listbox item under the mouse pointer.
lindx = Int((tPoint2.Y - dTp) / ApproxListItemHeight) _
+ oListBox.Object.TopIndex
oListBox.Object.Selected(lindx - 1) = True
End Sub
Private Sub wsEvents_SelectionChange(ByVal Target As Range)
Dim iMatchPos As Integer
bListBoxActivated = False
' On Error Resume Next
If Target.Address = P_InputCell.Address Then
Application.EditDirectlyInCell = False
'the caret is lost if editing the worksheet
'so let's recreate one here
DestroyCaret
CreateCaret lHwnd, 0, 1, 15
Else
bInputCellToBeRefreshed = True
HideListBox
'restore initial incell editing value
Application.EditDirectlyInCell = True
RefreshInputCell P_InputCell
ClearInvalidEntries
SetFocus lHwnd
End If
End Sub
'******************Class Properties/Methods **************
Public Property Set InputCell(ByVal vNewValue As Range)
Set P_InputCell = vNewValue
End Property
Public Property Set SearchList(ByVal vNewValue As Range)
Set P_SearchList = vNewValue
End Property
Public Property Let FormatInputCell(ByVal vNewValue As Boolean)
P_FormatInputCell = vNewValue
End Property
Public Sub Execute()
Call ProcessKeyStrokes
End Sub
Public Sub DestroyMe()
Call StopKeyProcessing
End SubAcouple of things :
1 - If the custom blinking cursor is ill-placed over the inputcell text or placed too far you can easily adjust it by changing the value of the constante OffsetPixels located in the main routine ProcessKeyStrokes.
2 - The ws Zoom must be set to 100 for the class to work properly otherwise the listbox gets disproportioned.
I am curious to know if this works for other than Office XP because of the ListView Control added at runtime so I would appreciate any feedback on this.
Regards.
