This makes it easy to provide datasheet-like navigation to continuous forms. To enable the this functionality, you only need to add four lines to the continuous form’s module:
Private kn As KeyNavigator
Private Form_Load()
Set kn = New KeyNavigator
kn.Init Me
End Sub
Private Form_Close()
Set kn = Nothing
End Sub
Then the KeyNavigator will handle the keyboard navigation for you.
CODE
Private col As VBA.Collection
Private WithEvents frm As Access.Form
Private ctl As Access.Control
Private lngMaxTabs As Long
Private Const Evented As String = "[Event Procedure]"
Public Sub Init(SourceForm As Access.Form)
On Error GoTo ErrHandler
Dim varTabIndex As Variant
Set frm = SourceForm
frm.KeyPreview = True
frm.OnKeyDown = Evented
With frm
For Each ctl In .Section(acDetail).Controls
varTabIndex = Null
On Error GoTo NoPropertyErrHandler
varTabIndex = ctl.TabIndex
On Error GoTo ErrHandler
If Not IsNull(varTabIndex) Then
col.Add ctl, CStr(varTabIndex)
If lngMaxTabs < CLng(varTabIndex) Then
lngMaxTabs = CLng(varTabIndex)
End If
End If
Next
End With
ExitProc:
On Error Resume Next
Exit Sub
NoPropertyErrHandler:
Select Case Err.Number
Case 438
varTabIndex = Null
Resume Next
End Select
ErrHandler:
Select Case Err.Number
Case Else
VBA.MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Sub
Private Sub Class_Initialize()
On Error GoTo ErrHandler
Set col = New VBA.Collection
ExitProc:
On Error Resume Next
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
VBA.MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Sub
Private Sub Class_Terminate()
On Error GoTo ErrHandler
Do Until col.Count = 0
col.Remove 1
Loop
Set ctl = Nothing
Set col = Nothing
Set frm = Nothing
ExitProc:
On Error Resume Next
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
VBA.MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Sub
Private Sub frm_KeyDown(KeyCode As Integer, Shift As Integer)
On Error GoTo ErrHandler
Dim i As Long
Dim bolAdvance As Boolean
Dim bolInsertable As Boolean
bolInsertable = frm.AllowAdditions
If bolInsertable Then
Select Case True
Case TypeOf frm.Recordset Is DAO.Recordset
bolInsertable = frm.Recordset.Updatable
Case TypeOf frm.Recordset Is ADODB.Recordset
bolInsertable = Not (frm.Recordset.LockType = adLockReadOnly)
Case Else
bolInsertable = False
End Select
End If
Select Case KeyCode
Case vbKeyUp
With frm.Recordset
If frm.NewRecord Then
If Not (.BOF And .EOF) Then
.MoveLast
End If
Else
If Not (.BOF And .EOF) Then
.MovePrevious
If .BOF And Not .EOF Then
.MoveFirst
End If
End If
End If
End With
KeyCode = &H0
Case vbKeyDown
With frm.Recordset
If Not frm.NewRecord Then
If Not (.BOF And .EOF) Then
.MoveNext
If .EOF And Not .BOF Then
If bolInsertable Then
frm.SelTop = .RecordCount + 1
End If
End If
Else
If bolInsertable Then
frm.SelTop = .RecordCount + 1
End If
End If
End If
End With
KeyCode = &H0
Case vbKeyLeft
Set ctl = frm.ActiveControl
On Error GoTo NoPropertyErrHandler
bolAdvance = (ctl.SelStart = 0)
On Error GoTo ErrHandler
If bolAdvance Then
Do
If ctl.TabIndex = 0 Then
With frm.Recordset
If frm.NewRecord Then
.MoveLast
Else
.MovePrevious
End If
If .BOF And Not .EOF Then
.MoveFirst
End If
End With
Set ctl = col(CStr(lngMaxTabs))
Else
Set ctl = col(CStr(ctl.TabIndex - 1))
End If
Loop Until ((ctl.TabStop = True) And (ctl.Enabled = True) And (ctl.Visible = True))
ctl.SetFocus
KeyCode = &H0
End If
Case vbKeyRight
Set ctl = frm.ActiveControl
On Error GoTo NoPropertyErrHandler
bolAdvance = (ctl.SelStart >= Len(ctl.Value))
On Error GoTo ErrHandler
If bolAdvance Then
Do
If ctl.TabIndex = lngMaxTabs Then
With frm.Recordset
If Not frm.NewRecord Then
.MoveNext
End If
If .EOF And Not .BOF Then
If bolInsertable Then
frm.SelTop = .RecordCount + 1
End If
End If
End With
Set ctl = col("0")
Else
Set ctl = col(CStr(ctl.TabIndex + 1))
End If
Loop Until ((ctl.TabStop = True) And (ctl.Enabled = True) And (ctl.Visible = True))
ctl.SetFocus
KeyCode = &H0
End If
End Select
ExitProc:
On Error Resume Next
Exit Sub
NoPropertyErrHandler:
Select Case Err.Number
Case 94
Resume ExitProc
Case 438
bolAdvance = True
Resume Next
End Select
ErrHandler:
Select Case Err.Number
Case 3021, 3426
Resume Next
Case Else
VBA.MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Sub