weArrowKeyNav Class
A common problem in designing continuous forms in Access is what to do about the unintuitive behavior of the up and down arrow keys.
Instead of moving the focus of the cursor up and down visually within the form, the up and down arrow keys actually move the cursor left and right between the previous and next controls (instead of the previous and next records).
My Solution
To solve this problem, I created a class module that overrides the default behavior of the up and down arrow keys. When this class is enabled on a form, pressing the up arrow moves the focus to the previous record while pressing the down arrow moves the focus to the next record.
Enabling this behavior on a form requires only two lines of code:
Option Explicit
Option Compare Database
Dim ArrowKeyNav As New weArrowKeyNav
Private Sub Form_Load()
ArrowKeyNav.FullArrowKeyNav Me.Form
End SubThe Code: weArrowKeyNav Class
The code below is simpler than it first appears. Much of the code serves no purpose other than to detect the dropped-down state of a combo box control.
'---------------------------------------------------------------------------------------
' Module : weArrowKeyNav
' Author : Mike Wolfe (https://nolongerset.com/wearrowkeynav-class/)
' Date : 9/14/2011 - 5/18/2021 20:51
' Purpose : Subclass controls to provide Excel-style Up/Down arrow key navigation.
' Usage : There are two ways to use this class. The simple way, which enables
' full arrow key navigation for all visible and enabled controls in the
' detail section of a form, can be implemented with a single call.
' The more explicit and flexible way is to enable the functionality on
' a per-control basis.
' Simple -
' 1. Add the following to the declaration section of the form module:
' Dim ArrowKeyNav As New weArrowKeyNav
' 2. Add the following to the Form_Load/Form_Open event:
' ArrowKeyNav.FullArrowKeyNav Me.Form
' Explicit - This example assumes a form with a TextBox named ItemAmt,
' a ComboBox named AcctPicker, and a CheckBox named IncOn1099
' 1. Add the following to the declaration section of the form module:
' Dim weAcctPicker As New weArrowKeyNav
' Dim weItemAmt As New weArrowKeyNav
' Dim weIncOn1099 As New weArrowKeyNav
' 2. Add the following to the Form_Load/Form_Open event:
' Private Sub Form_Load()
' 'Set the appropriate controls as instances of the class
' Set weAcctPicker.Control = Me.AcctPicker
' Set weItemAmt.Control = Me.ItemAmt
' Set weIncOn1099.Control = Me.IncOn1099
' End Sub
'---------------------------------------------------------------------------------------
Option Compare Database
Option Explicit
Private WithEvents weTextBox As TextBox
Private WithEvents weComboBox As ComboBox
Private WithEvents weCheckBox As CheckBox
Private CtlColl As Collection
'retrieved on 10/11/2011 @ 11:31 from: http://access.mvps.org/access/api/api0052.htm
'******* Code Start *********
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
'
' retrieves the name of the class to which the specified window belongs.
#If VBA7 Then
Private Declare PtrSafe Function apiGetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hWnd As LongPtr, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
#Else
Private Declare Function apiGetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hWnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) _
As Long
#End If
' retrieves a handle to the specified child window's parent window.
#If VBA7 Then
Private Declare PtrSafe Function apiGetParent Lib "user32" _
Alias "GetParent" _
(ByVal hWnd As LongPtr) _
As LongPtr
#Else
Private Declare Function apiGetParent Lib "user32" _
Alias "GetParent" _
(ByVal hWnd As Long) _
As Long
#End If
' retrieves information about the specified window. The function also
' retrieves the 32-bit (long) value at the specified offset into the
' extra window memory of a window.
#If Win64 Then
Private Declare PtrSafe Function apiGetWindowLong Lib "user32" _
Alias "GetWindowLongPtrA" _
(ByVal hWnd As LongPtr, _
ByVal nIndex As Long) _
As LongPtr
#Else
#If VBA7 Then
Private Declare PtrSafe Function apiGetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hWnd As LongPtr, _
ByVal nIndex As Long) _
As Long
#Else
Private Declare Function apiGetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) _
As Long
#End If
#End If
' retrieves a handle to the top-level window whose class name and
' window name match the specified strings. This function does not search
' child windows. This function does not perform a case-sensitive search.
#If VBA7 Then
Private Declare PtrSafe Function apiFindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) _
As LongPtr
#Else
Private Declare Function apiFindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) _
As Long
#End If
' retrieves a handle to a window that has the specified relationship
' (Z order or owner) to the specified window
#If VBA7 Then
Private Declare PtrSafe Function apiGetWindow Lib "user32" _
Alias "GetWindow" _
(ByVal hWnd As LongPtr, _
ByVal wCmd As Long) _
As LongPtr
#Else
Private Declare Function apiGetWindow Lib "user32" _
Alias "GetWindow" _
(ByVal hWnd As Long, _
ByVal wCmd As Long) _
As Long
#End If
' The class name for an Access combo's drop down listbox window
Private Const ACC_CBX_LISTBOX_CLASS = "OGrid"
' Class name for the Access window
Private Const ACC_MAIN_CLASS = "OMain"
' Class name for an Access combo's drop down listbox's parent window
Private Const ACC_CBX_LISTBOX_PARENT_CLASS = "ODCombo"
' class name for an Access form's client window
Private Const ACC_FORM_CLIENT_CLASS = "OFormSub"
' class name for Edit controls in Access
Private Const ACC_CBX_EDIT_CLASS = "OKttbx"
' class name for VB combo's drop down listbox's parent window (SDI)
Private Const VB_CBX_LISTBOX_PARENT_CLASS = "#32769" ' // Desktop
' class name for VB combo's drop down listbox window
Private Const VB_CBX_LISTBOX_CLASS = "ComboLBox"
' handle identifies the child window at the top of the Z order,
' if the specified window is a parent window
Private Const GW_CHILD = 5
' Retrieves the window styles.
Private Const GWL_STYLE = (-16)
' flag denoting that a window is visible
Private Const WS_VISIBLE = &H10000000
Private Function fIsComboOpen() As Boolean
' returns true if a combo box on the form is dropped down
' only one combo can have the focus => only one drop down
'
Static hWnd As Variant ' Long/LongPtr
Static hWndCBX_LBX As Variant ' Long/LongPtr
hWnd = 0: hWndCBX_LBX = 0
' Start with finding the window with "ODCombo" class name
hWnd = apiFindWindow(ACC_CBX_LISTBOX_PARENT_CLASS, _
vbNullString)
' Parent window of ODCombo is the Access window
If apiGetParent(hWnd) = hWndAccessApp Then
' Child window of ODCombo window is the
' drop down listbox associated with a combobox
hWndCBX_LBX = apiGetWindow(hWnd, GW_CHILD)
' another check to confirm that we're looking at the right window
If fGetClassName(hWndCBX_LBX) = _
ACC_CBX_LISTBOX_CLASS Then
' Finally, if this window is visible,
If apiGetWindowLong(hWnd, GWL_STYLE) And WS_VISIBLE Then
' the Combo must be open
fIsComboOpen = True
End If
End If
End If
End Function
Private Function fGetClassName(hWnd As Variant) ' Long/LongPtr)
Dim strBuffer As String
Dim lngLen As Long
Const MAX_LEN = 255
strBuffer = Space$(MAX_LEN)
lngLen = apiGetClassName(hWnd, strBuffer, MAX_LEN)
If lngLen > 0 Then fGetClassName = Left$(strBuffer, lngLen)
End Function
'******* Code End *********
Public Sub FullArrowKeyNav(Frm As Form)
Dim Ctl As Control
Set CtlColl = New Collection
For Each Ctl In Frm.Section(acDetail).Controls
Select Case Ctl.ControlType
Case acTextBox, acComboBox, acCheckBox
If Ctl.Enabled And Ctl.Visible Then
Dim NavCtl As weArrowKeyNav
Set NavCtl = New weArrowKeyNav
Set NavCtl.Control = Ctl
CtlColl.Add NavCtl
End If
End Select
Next Ctl
End Sub
Public Property Set Control(ByVal Ctl As Control)
Select Case Ctl.ControlType
Case acTextBox
Set weTextBox = Ctl
weTextBox.OnKeyDown = "[Event Procedure]"
Case acComboBox
Set weComboBox = Ctl
weComboBox.OnKeyDown = "[Event Procedure]"
Case acCheckBox
Set weCheckBox = Ctl
weCheckBox.OnKeyDown = "[Event Procedure]"
End Select
End Property
Private Sub Class_Terminate()
On Error Resume Next
If Not CtlColl Is Nothing Then
Dim Ctl As Object
For Each Ctl In CtlColl
Set Ctl = Nothing
Next Ctl
Set CtlColl = Nothing
End If
End Sub
Private Sub weCheckBox_KeyDown(KeyCode As Integer, Shift As Integer)
KeyCode = KeyDown(weCheckBox, KeyCode, Shift)
End Sub
Private Sub weComboBox_KeyDown(KeyCode As Integer, Shift As Integer)
If fIsComboOpen() Then Exit Sub
KeyCode = KeyDown(weComboBox, KeyCode, Shift)
End Sub
Private Sub weTextBox_KeyDown(KeyCode As Integer, Shift As Integer)
KeyCode = KeyDown(weTextBox, KeyCode, Shift)
End Sub
Private Function KeyDown(Ctl As Control, KeyCode As Integer, Shift As Integer) As Integer
Dim rs As Object ' DAO.Recordset or ADODB.Recordset
On Error GoTo Err_KeyDown
Dim Frm As Form
Set Frm = GetFormFromCtl(Ctl)
KeyDown = 0
Set rs = Frm.Recordset
Select Case KeyCode
Case vbKeyDown
If Not rs.EOF Then
rs.MoveNext
If rs.EOF Then
If Frm.AllowAdditions Then
'Every call to rs.AddNew increments the AutoNumber,
' even if we don't edit the new record;
'Setting Frm.SelTop avoids this problem
Frm.SelTop = rs.RecordCount + 1
Else
rs.MovePrevious
End If
End If
Ctl.SetFocus
ElseIf Frm.AllowAdditions Then
Frm.SelTop = rs.RecordCount + 1
End If
Case vbKeyUp
If Not rs.BOF Then
If Frm.NewRecord Then
rs.MoveLast
Else
rs.MovePrevious
If rs.BOF Then rs.MoveNext
End If
Ctl.SetFocus
End If
Case Else
KeyDown = KeyCode
End Select
Exit_KeyDown:
Exit Function
Err_KeyDown:
Select Case Err.Number
Case 3420
'Object invalid or no longer set
' This can happen if we make changes to the underlying recordset in the form's AfterUpdate event
Case 3426
'This action was cancelled by an associated object.
' Don't log this error; just allow it to pass silently through.
' This is the error generated when user tries to move to a different record and
' can't because of a missing required field or some other failed validation.
Case Else
MsgBox Err.Description, vbExclamation, "Error " & Err.Number
End Select
Resume Exit_KeyDown
Resume
End Function
Private Function GetFormFromCtl(Ctl As Control) As Form
If TypeOf Ctl.Parent Is Form Then
Set GetFormFromCtl = Ctl.Parent
Else
'Recursively call the function passing the current control's
' parent until eventually we arrive at the form
Set GetFormFromCtl = GetFormFromCtl(Ctl.Parent)
End If
End FunctionA short note about the "we" prefix
I use semantic prefixes with my code modules to help organize them within the VBA editor. The "we" portion of weArrowKeyNav conveys that the class relies heavily on the WithEvents keyword to provide its functionality.
Image by GuHyeok Jeong from Pixabay