UtterAccess HomeUtterAccess Wiki

Welcome Guest ( Log In | Register )

Custom Search
Edit Discussion
> KeyNavigator    

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:

CODE
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

Creative Commons License
KeyNavigator by UtterAccess Wiki is licensed under a Creative Commons Attribution-ShareAlike 3.0 Unported License.
Editing and revision of the content is freely encouraged; for details, see Expected Usage.

Edit Discussion
Custom Search
Thank you for your support!
This page has been accessed 3,368 times.  This page was last modified 16:14, 23 October 2012 by BananaRepublic.   Disclaimers