Option Explicit
#If False Then
  ' Just to Maintain Case
  Private adoMoveFirst
  Private adoStayBOF

  Private adoMoveLast
  Private adoStayEOF
  Private adoNEW

  Private adoADD
  Private adoDEL
  Private adoBOF
  Private adoBOFX
  Private adoPREV
  Private adoREFRESH
  Private adoNEXT
  Private adoEOFX
  Private adoEOF
  Private adoSAVE
  Private adoUNDO
  Private adoCOUNT
#End If

Private Enum ADOButtons
  adoNEW
  adoDEL
  adoBOF
  adoBOFX
  adoPREV
  adoREFRESH
  adoNEXT
  adoEOFX
  adoEOF
  adoSAVE
  adoUNDO
  adoCOUNT
End Enum

' Control Properties
Private mDelayDelete      As Boolean
Private mBackColor       As OLE_COLOR
Private mForeColor       As OLE_COLOR
Private mBOFAction       As DataBOFconstants
Private mEOFAction       As DataEOFConstants
Private mBookMark        As Variant

' Private Variables
Private mBusy          As Boolean
Private mAdding         As Boolean
Private mIsDirty        As Boolean
Private mToolTips        As Variant
' Control Events
Public Event AddNew(Cancel As Boolean)
Public Event Changed(Action As ADODB.EventReasonEnum)
Public Event Delete(Cancel As Boolean)
Public Event Save(Cancel As Boolean)
Public Event Undo(Cancel As Boolean)

' RecordSet Events
Private WithEvents Recordset  As ADODB.Recordset

' Read / Write Properties
Public Property Let BackColor(vdata As OLE_COLOR)
  mBackColor = vdata
  UserControl.BackColor = mBackColor
  PropertyChanged "BackColor"
End Property
Public Property Get BackColor() As OLE_COLOR
  BackColor = mBackColor
End Property

Public Property Let DelayDelete(vdata As Boolean)
  mDelayDelete = vdata
  PropertyChanged "DelayDelete"
End Property
Public Property Get DelayDelete() As Boolean
  DelayDelete = mDelayDelete
End Property

Public Property Let ForeColor(vdata As OLE_COLOR)
  mForeColor = vdata
  UserControl.ForeColor = mForeColor
  PropertyChanged "ForeColor"
End Property
Public Property Get ForeColor() As OLE_COLOR
  ForeColor = mForeColor
End Property

' ADO Data Properties
' Read Only Properties
Public Property Get Connection() As ADODB.Connection
  If Recordset Is Nothing Then Exit Property
  Set Connection = Recordset.ActiveConnection
End Property

Public Property Let BOFAction(ByVal New_BOFAction As DataBOFconstants)
  mBOFAction = New_BOFAction
  PropertyChanged "BOFAction"
End Property
Public Property Get BOFAction() As DataBOFconstants
  BOFAction = mBOFAction
End Property

Public Property Let EOFAction(ByVal New_EOFAction As DataEOFConstants)
  mEOFAction = New_EOFAction
  PropertyChanged "EOF Action"
End Property
Public Property Get EOFAction() As DataEOFConstants
  EOFAction = mEOFAction
End Property

Public Property Set DataSource(vdata As ADODB.Recordset)
  Set Recordset = vdata
  Enable
End Property
Public Property Get DataSource() As ADODB.Recordset
  Set DataSource = Recordset
End Property

Public Function EmptyRS() As Boolean

  On Error Resume Next

  'Checks for an EMPTY RecordSet
  EmptyRS = True
  If Not Recordset Is Nothing Then
    EmptyRS = ((Recordset.BOF = True) And (Recordset.EOF = True))
  End If

End Function

Private Sub Enable()

  If mBusy Then Exit Sub

  Dim lHasData  As Boolean
  Dim lPos    As Long
  Dim lCount   As Long
  Dim lMidway   As Long

  lHasData = Not EmptyRS

  If lHasData Then
    On Error Resume Next
    lPos = Recordset.AbsolutePosition
    On Error GoTo 0
    lCount = Recordset.RecordCount
  End If

  ' Do Navigation First
  With cmdNav(adoBOF)
    .Enabled = lHasData
    If .Enabled Then .Enabled = Recordset.Supports(adMovePrevious) And lPos > 1 And (Not mAdding Or mIsDirty)
  End With
  With cmdNav(adoBOFX)
    .Enabled = lHasData
    If .Enabled Then .Enabled = Recordset.Supports(adMovePrevious) And lPos > 2 And (Not mAdding Or mIsDirty)
  End With
  With cmdNav(adoPREV)
    .Enabled = lHasData
    If .Enabled Then .Enabled = Recordset.Supports(adMovePrevious) And lPos > 1 And (Not mAdding Or mIsDirty)
  End With
  With cmdNav(adoNEXT)
    .Enabled = lHasData
    If .Enabled Then .Enabled = lPos < lCount And (Not mAdding Or mIsDirty)
  End With
  With cmdNav(adoEOFX)
    .Enabled = lHasData
    If .Enabled Then .Enabled = lPos < lCount - 1 And (Not mAdding Or mIsDirty)
  End With
  With cmdNav(adoEOF)
    .Enabled = lHasData
    If .Enabled Then .Enabled = lPos < lCount And (Not mAdding Or mIsDirty)
  End With
  ' Edit Controls
  With cmdNav(adoREFRESH)
    .Enabled = lHasData
    If .Enabled Then
      .Enabled = Recordset.Supports(adResync)
      If .Enabled Then .Enabled = (Not mAdding And Not mIsDirty)
    End If
  End With
  With cmdNav(adoNEW)
    .Enabled = lHasData
    If .Enabled Then
      .Enabled = Recordset.Supports(adAddNew)
      If .Enabled Then .Enabled = (Not mAdding And Not mIsDirty)
    End If
  End With
  With cmdNav(adoDEL)
    .Enabled = lHasData
    If .Enabled Then
      .Enabled = Recordset.Supports(adDelete)
      If .Enabled Then .Enabled = (Not mAdding And Not mIsDirty)
    End If
  End With
  With cmdNav(adoSAVE)
    .Enabled = lHasData
    If .Enabled Then
      .Enabled = Recordset.Supports(adUpdate) Or Recordset.Supports(adUpdateBatch)
      If .Enabled Then .Enabled = mIsDirty Or mAdding
    End If
  End With
  With cmdNav(adoUNDO)
    .Enabled = lHasData
    If .Enabled Then .Enabled = Recordset.Supports(adUpdate) Or Recordset.Supports(adUpdateBatch)
    If .Enabled Then .Enabled = mIsDirty Or mAdding
  End With

  txtPOS.Text = lPos & " / " & lCount

End Sub

'#
'# Button Events
'#
Private Sub cmdNAV_Click(Index As Integer)

  If mBusy Then Exit Sub

  Dim lCancel   As Boolean
  Dim lHasData  As Boolean
  Dim lPos    As Long
  Dim lCount   As Long
  Dim lMidway   As Long

  On Error GoTo LocalError
  lHasData = Not EmptyRS

  If lHasData Then
    With Recordset
      lPos = .AbsolutePosition
      lCount = .RecordCount
      Select Case Index
        Case adoBOF
          If .RecordCount > 0 Then
            If .Supports(adMovePrevious) Then .MoveFirst
            If Not .BOF And Not .EOF Then mBookMark = .Bookmark
          End If
        Case adoBOFX
          ' Move between Current and First
          lMidway = (.AbsolutePosition \ 2) * -1
          If .Supports(adMovePrevious) Then .Move lMidway
          If Not .BOF And Not .EOF Then mBookMark = .Bookmark
        Case adoPREV
          If .BOF Then
            Select Case mBOFAction
              Case DataBOFconstants.vbMoveFirst
                If .Supports(adMovePrevious) Then .MoveFirst
                If Not .BOF And Not .EOF Then mBookMark = .Bookmark
              Case DataBOFconstants.vbBOF:    ' Do nothing
            End Select
          Else
            If .Supports(adMovePrevious) Then .MovePrevious
            If Not .BOF And Not .EOF Then mBookMark = .Bookmark
          End If
        Case adoNEXT
          If .EOF Then
            Select Case mEOFAction
              Case DataEOFConstants.vbAddNew
                If .Supports(adAddNew) Then
                  cmdNAV_Click adoNEW
                  Exit Sub
                End If
              Case DataEOFConstants.vbMoveLast
                .MoveLast
                If Not .BOF And Not .EOF Then mBookMark = .Bookmark
              Case DataEOFConstants.vbEOF:    ' Do nothing
            End Select
          Else
            .MoveNext
            If Not .BOF And Not .EOF Then mBookMark = .Bookmark
          End If
        Case adoEOFX
          lMidway = (.RecordCount - .AbsolutePosition) \ 2
          .Move lMidway
          If .EOF Then .MoveLast ' should never happen
          If Not .BOF And Not .EOF Then mBookMark = .Bookmark
        Case adoEOF
          .MoveLast
          If Not .BOF And Not .EOF Then mBookMark = .Bookmark
        Case adoREFRESH
          If .Supports(adResync) Then .Requery
        Case adoNEW
          If .Supports(adAddNew) Then
            RaiseEvent AddNew(lCancel)
            If Not lCancel Then
              mAdding = True
              If Not .BOF And Not .EOF Then mBookMark = .Bookmark
              .AddNew
            End If
          End If
        Case adoUNDO
          If .EditMode = adEditAdd Then
            RaiseEvent Undo(lCancel)
            If Not lCancel Then
              mAdding = False
              If .Supports(adUpdateBatch) Then
                .CancelBatch adAffectAllChapters
              ElseIf .Supports(adUpdate) Then
                .CancelUpdate
              End If
            End If
          End If
          If mBookMark > 0 Then
            .Bookmark = mBookMark
            mBookMark = 0
          End If
        Case adoSAVE
          ' Check if the Record is Dirty
          RaiseEvent Save(lCancel)
          If Not lCancel Then
            If .Supports(adUpdateBatch) Then
              .UpdateBatch
            ElseIf .Supports(adUpdate) Then
              .Update
            End If
          End If
        Case adoDEL
          RaiseEvent Delete(lCancel)
          If Not lCancel Then
            If .Supports(adDelete) Then
              .Delete
              On Error Resume Next
              If .LockType = adLockBatchOptimistic Then
                .UpdateBatch
                If Err.Number <> 0 Then .CancelBatch
              ElseIf .LockType <> adLockReadOnly Then
                .Update
                If Err.Number <> 0 Then .CancelUpdate
              End If
              On Error GoTo 0
            End If
            cmdNAV_Click adoNEXT
            Exit Sub
          End If
      End Select
    End With
  End If

  Enable
Exit Sub
LocalError:
  On Error Resume Next
  Recordset.CancelUpdate
  On Error GoTo 0
End Sub

'#
'# RecordSet Events
'#
Private Sub Recordset_EndOfRecordset(fMoreData As Boolean, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  '
End Sub

Private Sub Recordset_FetchComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  '
End Sub

Private Sub Recordset_FetchProgress(ByVal Progress As Long, ByVal MaxProgress As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  '
End Sub

Private Sub Recordset_FieldChangeComplete(ByVal cFields As Long, ByVal Fields As Variant, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  ' After WillChangeField
End Sub

Private Sub Recordset_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  ' After WillMove
  RaiseEvent Changed(adReason)
  mIsDirty = False
  Enable
End Sub

Private Sub Recordset_RecordChangeComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  ' After WillChangeRecord
  Select Case adReason
    Case adRsnAddNew, adRsnDelete, adRsnFirstChange
      mIsDirty = True
  End Select
  Enable
End Sub

Private Sub Recordset_RecordsetChangeComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  ' After WillChangeRecordset
End Sub

Private Sub RecordSet_WillChangeField(ByVal cFields As Long, ByVal Fields As Variant, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  ' Before the Value property changes
  mIsDirty = True
  Enable
End Sub

Private Sub Recordset_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)

  Select Case adReason
    Case adRsnAddNew
      mAdding = True
      mIsDirty = True
    Case adRsnDelete, adRsnFirstChange
      mIsDirty = True
      mAdding = False
    Case Else
      mAdding = False
      mIsDirty = False
  End Select

  Enable

End Sub

Private Sub Recordset_WillChangeRecordset(ByVal adReason As ADODB.EventReasonEnum, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  'On Recordset.Requery, Recordset.Resync, Recordset.Close, Recordset.Open, Recordset.Filter
End Sub

Private Sub Recordset_WillMove(ByVal adReason As ADODB.EventReasonEnum, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  ' On Recordset.Open, Recordset.MoveNext, Recordset.Move, Recordset.MoveLast,
  ' Recordset.MoveFirst, Recordset.MovePrevious, Recordset.Bookmark, Recordset.AddNew,
  ' Recordset.Delete, Recordset.Requery, Recordset.Resync
  If mIsDirty Or mAdding Then
    If Recordset.Supports(adUpdateBatch) Then
      Recordset.CancelBatch adAffectAllChapters
    ElseIf Recordset.Supports(adUpdate) Then
      Recordset.CancelUpdate
    End If
    mAdding = False
    mIsDirty = False
  End If

  Enable

End Sub

'#
'# User Control Events
'#
Private Sub UserControl_GetDataMember(DataMember As String, Data As Object)

  On Error GoTo LocalError

  If Recordset Is Nothing Then
    ' make sure various properties have been set
    ' Disable all Functions
  Else
    Set Data = Recordset
  End If
  
LocalError:
End Sub

Private Sub UserControl_Initialize()

  Dim x As Integer
  ReDim mToolTips(11)

  mToolTips(adoNEW) = "Add a New Record"
  mToolTips(adoDEL) = "Delete Record"
  mToolTips(adoBOF) = "Move to First Record"
  mToolTips(adoBOFX) = "Move miday between Current and First Record"
  mToolTips(adoPREV) = "Move to Previous Record"
  mToolTips(adoREFRESH) = "Refresh ALL Records"
  mToolTips(adoNEXT) = "Move to Next Record"
  mToolTips(adoEOFX) = "Move midway between Current and Last Record"
  mToolTips(adoEOF) = "Move to Last Record"
  mToolTips(adoSAVE) = "Save / Update the Current Record"
  mToolTips(adoUNDO) = "Cancel all changes"

  With UserControl
    .Height = 360
    .BackColor = vbButtonFace
    .ForeColor = vbButtonText
  End With

  With cmdNav(0)
    .Top = 0
    .Left = 0
    .ToolTipText = mToolTips(0)
    .Width = UserControl.Height
    .Height = .Width
  End With

  For x = 1 To 11
    With cmdNav(x)
      .Top = 0
      If x < 11 Then
        .ToolTipText = mToolTips(x)
        .Left = cmdNav(0).Width * x
        .Width = cmdNav(0).Width
      End If
      .Height = cmdNav(0).Height
    End With
  Next x

  With txtPOS
    .Enabled = True
    .Locked = True
    .Appearance = 1
    .BorderStyle = vbBSSolid
    .BackColor = vbBlack
    .ForeColor = vbGreen
    .Left = cmdNav(10).Left + cmdNav(10).Width + 50
    .Top = 50
    .Height = cmdNav(0).Height - 100
  End With

  With cmdNav(11)
    .Top = 0
    .Left = txtPOS.Left + txtPOS.Width
    .Height = cmdNav(0).Height
  End With

End Sub

Private Sub UserControl_InitProperties()

  Set UserControl.Font = Ambient.Font
  UserControl.BackColor = vbButtonFace
  UserControl.ForeColor = vbButtonText

End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

  mBackColor = PropBag.ReadProperty("BackColor", vbButtonFace)
  mDelayDelete = PropBag.ReadProperty("DelayDelete", True)
  mForeColor = PropBag.ReadProperty("ForeColor", vbButtonText)
  mBOFAction = PropBag.ReadProperty("BOFAction", DataBOFconstants.vbMoveFirst)
  mEOFAction = PropBag.ReadProperty("EOFAction", DataEOFConstants.vbMoveLast)
  Enable

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

  'Write property values to storage
  Call PropBag.WriteProperty("BackColor", mBackColor, vbButtonFace)
  Call PropBag.WriteProperty("DelayDelete", mDelayDelete, True)
  Call PropBag.WriteProperty("ForeColor", mForeColor, vbButtonText)
  Call PropBag.WriteProperty("BOFAction", mBOFAction, DataBOFconstants.vbMoveFirst)
  Call PropBag.WriteProperty("EOFAction", mEOFAction, DataEOFConstants.vbMoveLast)

End Sub

Private Sub UserControl_Resize()

  On Error Resume Next
  If UserControl.Height >= 360 Then UserControl.Height = 360
  With cmdNav(11)
    .Width = UserControl.ScaleWidth - (txtPOS.Left + txtPOS.Width)
  End With
  
End Sub

Private Sub UserControl_Terminate()

  On Error Resume Next
  
  If Not Recordset Is Nothing Then
    Recordset.Close
    Set Recordset = Nothing
  End If
  
  Err.Clear

End Sub