Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,621
- Office Version
- 2016
- Platform
- Windows
Hi all,
Here is an example: http://www.savefile.com/files/1228450
I have been working on a little project that requires making entries from an unsorted list into an input cell . The list extends over hundreds of rows and the syntax of the items on the list is irregular and difficult to remember.
Neither the XL native Data validation or the Pick From Drop-down List on the Cell menu are good for very long lists.
So i thought that if i got a drop down list to pop up with the corresponding matches dynamically as i type in the first letters (similar ot the AutoComplete feature in IE) , i would save plenty of time in the data entry process and avoid making syntax mistakes.
The AutoWordCompleter Class i have come up with works fairly well except for one major problem I have come up against and that is when typing too fast, the Class goes out of scope abruptly and the programm stops working without giving the Class a chance to cleanup
. I couldn't get the Terminate event handler to do the cleanup either !
I am currently using a Loop to watch for key strokes so I have tried using a mouse hook instead and even a timer to see if they can avoid this problem but with no luck so far.
I am open to any suggestions in order to get around this - not being able to type too fast - problem .
Here is the Class code : (cAutoWordCompleter)
and here is how to call the Class in a Standard Module:
Should the Class go out of scope when typing too fast , here is a routine that does the Class clean up for your convinience: (where Range("D3") is the hard-coded input cell address. Change this as required) :
*Note : If the Input Cell blinking cursor is ill-placed over the text or too far this can be adjusted by changing the value of the Const :OffsetPixels declared in the ProcessKeyStrokes main Routine located in the Class module.
Regards.
Here is an example: http://www.savefile.com/files/1228450
I have been working on a little project that requires making entries from an unsorted list into an input cell . The list extends over hundreds of rows and the syntax of the items on the list is irregular and difficult to remember.
Neither the XL native Data validation or the Pick From Drop-down List on the Cell menu are good for very long lists.
So i thought that if i got a drop down list to pop up with the corresponding matches dynamically as i type in the first letters (similar ot the AutoComplete feature in IE) , i would save plenty of time in the data entry process and avoid making syntax mistakes.
The AutoWordCompleter Class i have come up with works fairly well except for one major problem I have come up against and that is when typing too fast, the Class goes out of scope abruptly and the programm stops working without giving the Class a chance to cleanup
. I couldn't get the Terminate event handler to do the cleanup either !I am currently using a Loop to watch for key strokes so I have tried using a mouse hook instead and even a timer to see if they can avoid this problem but with no luck so far.
I am open to any suggestions in order to get around this - not being able to type too fast - problem .
Here is the Class code : (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 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 Const WM_LBUTTONDOWN = &H201
'__________________________________________________________
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 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_CHAR As Long = &H102
Private Const PM_REMOVE As Long = &H1
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 lPrevCellColor As Long
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 bListBoxDblClicked As Boolean
Private Sub ProcessKeyStrokes()
'adjust the value of this const to suit the
'machine screen resolution
Const OffsetPixels = 4
Dim Message As MSG
Dim sTempText As String
Dim sOddStrings As String
Dim lResult As Long
Dim bFoundMatch As Boolean
Dim iMatchPos
'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
'dont clear the inputcell if value is entered from the lbx
If Not bListBoxDblClicked Then P_InputCell.ClearContents
RefreshInputCell P_InputCell
'color our inputcell so it easyly recognised
If lPrevCellColor = 0 Then
Call FormatInputCell
End If
'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
'setup advanced filter ranges in
'a newly added hidden sheet
If Not bAutoCompleteOn Then
SetUpSearchAndFilteredLists
bAutoCompleteOn = True
End If
'create a custom blinkikg cursor
CreateCaret lHwnd, 0, 1, 15 '
'store InCell edit property for later recovery
bInCellEdit = Application.EditDirectlyInCell
'in-cell editing can cause probs
'so let's disable it temporarly
Application.EditDirectlyInCell = False
'start watching for user keystrokes
Do While Not bCancelLoop
'check for keystrokes only if we are typing on our inputcell
If ActiveCell.Address = P_InputCell.Address Then
'wait for a message
WaitMessage
'check if it's a WM_KEYDOWN message
If PeekMessage(Message, lHwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
'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
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
HideListBox
Case Is = VK_LEFT
P_InputCell.Offset(, -1).Select
ClearInvalidEntries
HideListBox
'if the listbox is displayed,activate it
'and use the Up/Down keys to navigate it
Case Is = VK_UP
On Error Resume Next
If oListBox.Visible And _
GetFocus = GetListBoxHwnd Then
Call KeyUpProc
Else
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 Not oListBox.Visible Then ClearInvalidEntries
If GetFocus = GetListBoxHwnd Then
P_InputCell = oListBox.Object.Value
HideListBox
HideCaret lHwnd
RefreshInputCell P_InputCell
Else
SetFocus lHwnd
HideListBox
End If
P_InputCell.Offset(1).Select
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 If
End If
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
'restore initial incell editing value
Application.EditDirectlyInCell = bInCellEdit
'delete the hidden sheet
Application.DisplayAlerts = False
oHiddenWs.Delete
Application.DisplayAlerts = True
Set oHiddenWs = Nothing
'delete the listbox
oListBox.ShapeRange.Delete
Set oListBox = Nothing
'clear inputcell
RefreshCaret P_InputCell
DestroyCaret
P_InputCell.Interior.ColorIndex = lPrevCellColor
P_InputCell.ClearContents
On Error GoTo 0
End Sub
'************************Supporting Routines *****************
Private Function GetTextSize(text As String, font As font) 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 Err <> 0 And Len(P_InputCell) <> 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()
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 * 4
.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 ListBoxEvents_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'place the selected lisbox item
'into the inputcell upon dblclicking
P_InputCell = oListBox.Object.Value
oListBox.Visible = False
P_InputCell.Select
RefreshInputCell P_InputCell
'watch for the next keystroke
bListBoxDblClicked = True
Call ProcessKeyStrokes
End Sub
'function needed
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 wsEvents_SelectionChange(ByVal Target As Range)
Dim iMatchPos As Integer
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 = bInCellEdit
RefreshInputCell P_InputCell
End If
End Sub
Private Sub FormatInputCell()
'store initial inputcell color for later recovery
lPrevCellColor = P_InputCell.Interior.ColorIndex
P_InputCell.Interior.ColorIndex = 35 ' pale green
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 Sub Execute()
Call ProcessKeyStrokes
End Sub
Public Sub DestroyMe()
Call StopKeyProcessing
End Sub
'very important !!
'-----------------
'if the keyboard typing is too fast, the
'all the variables are reset and the Class
'goes out of scope before removing the
'temporary hidden worksheet and listbox !!
'The Terminate event of the class failes to do so
'so let's at least inform the user.
Private Sub Class_Terminate()
Dim sMessage As String
sMessage = "Attention !!!" & vbNewLine & vbNewLine
sMessage = sMessage & "Maybe you have typed in too fast." _
& vbNewLine & vbNewLine
sMessage = sMessage & _
"The Class has accidently gone out of scope and the program" _
& vbNewLine
sMessage = sMessage & _
"has not removed the temp hidden worksheet and listbox !" _
& vbNewLine & vbNewLine
sMessage = sMessage & _
"Proceed cleaning up the workbook manually now."
If Not bClassTerminatedProperly Then
Beep
MsgBox sMessage, vbCritical
End If
End Suband here is how to call the Class in a Standard Module:
Code:
Option Explicit
Private AutoWordCompleter As cAutoWordCompleter
Sub Test()
'prevent creating more than one
'AutoCompleter instance at a time !
If AutoWordCompleter Is Nothing Then
Set AutoWordCompleter = New cAutoWordCompleter
'assign the input and list ranges to the class
With AutoWordCompleter
Set .InputCell = Range("d3")
Set .SearchList = Range("a4:a2500")
.Execute
End With
Else
MsgBox "The AutoWordCompleter is already running.", vbInformation
End If
End Sub
Sub StoptheClass()
If Not AutoWordCompleter Is Nothing Then
AutoWordCompleter.DestroyMe
Set AutoWordCompleter = Nothing
Else
MsgBox "The AutoCompleter is already terminated.", vbInformation
End If
End SubShould the Class go out of scope when typing too fast , here is a routine that does the Class clean up for your convinience: (where Range("D3") is the hard-coded input cell address. Change this as required) :
Code:
Option Explicit
Sub CleanUp()
On Error GoTo errHandler
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("AutoCompleterWS").Delete
Application.DisplayAlerts = True
ActiveSheet.Shapes("AutoCompleterLB").Delete
Range("d3").Interior.ColorIndex = 0
Range("d3").ClearContents
Application.EditDirectlyInCell = True
Exit Sub
errHandler:
MsgBox "Temp hidden sheet and listbox already deleted.", vbInformation
End Sub*Note : If the Input Cell blinking cursor is ill-placed over the text or too far this can be adjusted by changing the value of the Const :OffsetPixels declared in the ProcessKeyStrokes main Routine located in the Class module.
Regards.
