Option Explicit
'>>>>>>>>>>>>>>>>>>>>>>>>
'ResMe Converted To A Property: Const BUTTON1 = "&Add"
'ResMe Converted To A Property: Const BUTTON2 = "&Edit"
'ResMe Converted To A Property: Const BUTTON3 = "&Delete"
'ResMe Converted To A Property: Const BUTTON4 = "&Close"
'ResMe Converted To A Property: Const BUTTON5 = "&Seek"
'ResMe Converted To A Property: Const BUTTON6 = "F&ilter"
'ResMe Converted To A Property: Const BUTTON7 = "&Cancel"
'ResMe Converted To A Property: Const BUTTON8 = "&Update"
'ResMe Converted To A Property: Const Label1 = "Field NAme:"
'ResMe Converted To A Property: Const Label2 = "Value (F4=Zoom)"
'ResMe Converted To A Property: Const MSG1 = "Add record"
'ResMe Converted To A Property: Const MSG2 = "Field Length Exceeded, Data Truncated!"
'ResMe Converted To A Property: Const MSG3 = "Delete Current Record?"
'ResMe Converted To A Property: Const MSG4 = "Edit record"
'ResMe Converted To A Property: Const MSG5 = "Enter Filter Expression:"
'ResMe Converted To A Property: Const MSG6 = "Opening Table"
'ResMe Converted To A Property: Const MSG7 = "Resizing Form"
'ResMe Converted To A Property: Const MSG8 = "Enter Seek Parameters"
'ResMe Converted To A Property: Const MSG9 = "Record Not Found"
'>>>>>>>>>>>>>>>>>>>>>>>>


'form variables
Public mrsFormRecordset As Recordset
Dim msTableName As String        'form recordset table name
Dim mvBookMark As Variant         'form bookmark
Dim mbEditFlag As Integer        'edit mode
Dim mbAddNewFlag As Integer      'add mode
Dim mbDataChanged As Integer
Dim mfrmSeek As New frmSeek      'seek form instance
Dim mlNumRows As Long            'total rows in Table

Private Sub cmdAdd_Click()
  On Error GoTo AddErr

  'set the mode
  mrsFormRecordset.AddNew
  lblStatus.Caption = MSG1
  mbAddNewFlag = True
  If mrsFormRecordset.RecordCount > 0 Then
    mvBookMark = mrsFormRecordset.Bookmark
  Else
    mvBookMark = vbNullString
  End If

  picChangeButtons.Visible = True
  picViewButtons.Visible = False
  cmdNext.Enabled = False
  cmdFirst.Enabled = False
  cmdLast.Enabled = False
  cmdPrevious.Enabled = False

  ClearDataFields Me, mrsFormRecordset.Fields.Count
  txtFieldData(0).SetFocus
  Exit Sub

AddErr:
  ShowError
End Sub

Private Sub cmdCancel_Click()
   On Error Resume Next

   picChangeButtons.Visible = False
   picViewButtons.Visible = True
   cmdNext.Enabled = True
   cmdFirst.Enabled = True
   cmdLast.Enabled = True
   cmdPrevious.Enabled = True

   mbEditFlag = False
   mbAddNewFlag = False
   If Len(mvBookMark) > 0 Then mrsFormRecordset.Bookmark = mvBookMark
   DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
   mbDataChanged = False
   DBEngine.Idle dbFreeLocks

End Sub

Private Sub txtFieldData_Change(Index As Integer)
  'just set the flag if data is changed
  'it gets reset to false when a new record is displayed
  mbDataChanged = True
End Sub

Private Sub txtFieldData_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
  If KeyCode = &H73 Then   'F4
    lblFieldName_DblClick Index

  ElseIf KeyCode = 34 And vsbScrollBar.Visible Then
    'pagedown with > 10 fields
    vsbScrollBar.Value = vsbScrollBar.Value - 3000

  ElseIf KeyCode = 33 And vsbScrollBar.Visible Then
    'pageup with > 10 fields
    vsbScrollBar.Value = vsbScrollBar.Value + 3000

  End If
End Sub

Private Sub txtFieldData_KeyPress(Index As Integer, KeyAscii As Integer)
  'only allow return when in edit of add mode
  If mbEditFlag Or mbAddNewFlag Then
    If KeyAscii = 13 Then
      KeyAscii = 0
      SendKeys "{Tab}"
    End If

  'throw away the keystrokes if not in add or edit mode
  ElseIf mbEditFlag = False And mbAddNewFlag = False Then
    KeyAscii = 0
  End If

End Sub

Private Sub txtFieldData_LostFocus(Index As Integer)
  On Error GoTo FldDataErr

  If mbDataChanged Then
    'store the data in the field
    mrsFormRecordset(Index) = txtFieldData(Index)
  End If

  'reset for valid or error condition
  mbDataChanged = False
  Exit Sub

FldDataErr:
  ShowError
  mbDataChanged = False
End Sub

Private Sub lblFieldName_DblClick(Index As Integer)
  On Error GoTo ZoomErr

  If mrsFormRecordset(Index).Type = dbText Or mrsFormRecordset(Index).Type = dbMemo Then
     If mrsFormRecordset(Index).Type = dbText Then
       gsZoomData = txtFieldData(Index).Text
     ElseIf mrsFormRecordset(Index).FieldSize() < gnGETCHUNK_CUTOFF Then
       gsZoomData = txtFieldData(Index).Text
     Else
       'add the rest of the field data with getchunk
       MsgBar "Getting Memo Field Data", True
       Screen.MousePointer = vbHourglass
       gsZoomData = txtFieldData(Index).Text & StripNonAscii(mrsFormRecordset(Index).GetChunk(gnGETCHUNK_CUTOFF, gnMAX_MEMO_SIZE))
       Screen.MousePointer = vbDefault
       MsgBar vbNullString, False
     End If
     frmZoom.Caption = Mid(lblFieldName(Index).Caption, 1, Len(lblFieldName(Index).Caption) - 1)
     frmZoom.Top = Top + 1200
     frmZoom.Left = Left + 250
     If mbAddNewFlag Or mbEditFlag Then
       frmZoom.cmdSave.Visible = True
       frmZoom.cmdCloseNoSave.Visible = True
     Else
       frmZoom.cmdClose.Visible = True
     End If
     If mrsFormRecordset(Index).Type = dbText Then
       frmZoom.txtZoomData.Text = gsZoomData
       frmZoom.Height = 1125
     Else
       frmZoom.txtMemo.Text = gsZoomData
       frmZoom.txtMemo.Visible = True
       frmZoom.txtZoomData.Visible = False
       frmZoom.Height = 2205
     End If
     frmZoom.Show vbModal
     If (mbAddNewFlag Or mbEditFlag) And gsZoomData <> "__CANCELLED__" Then
       If mrsFormRecordset(Index).Type = dbText And Len(gsZoomData) > mrsFormRecordset(Index).Size Then
         Beep
         MsgBox MSG2, 48
         txtFieldData(Index).Text = Mid(gsZoomData, 1, mrsFormRecordset(Index).Size)
       Else
         txtFieldData(Index).Text = gsZoomData
       End If
       mrsFormRecordset(Index) = txtFieldData(Index).Text
       mbDataChanged = False
     End If
  End If
  Exit Sub

ZoomErr:
  ShowError
End Sub

Private Sub cboIndexes_Click()
  On Error GoTo IndErr

  If mrsFormRecordset Is Nothing Then Exit Sub
  If mrsFormRecordset.Index = Mid(cboIndexes.Text, 1, InStr(1, cboIndexes.Text, ":") - 1) Then Exit Sub

  mrsFormRecordset.Index = Mid(cboIndexes.Text, 1, InStr(1, cboIndexes.Text, ":") - 1)
  DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
  mbDataChanged = False

  Exit Sub

IndErr:
  ShowError
End Sub

Private Sub cmdClose_Click()
  Unload Me
End Sub

Private Sub vsbScrollBar_Change()
  Dim nTop As Integer

  nTop = vsbScrollBar
  If (nTop - 960) Mod gnCTLARRAYHEIGHT = 0 Then
    picFields.Top = nTop
  Else
    picFields.Top = ((nTop - 960) \ gnCTLARRAYHEIGHT) * gnCTLARRAYHEIGHT + 960
  End If

End Sub

Private Sub cmdDelete_Click()
  On Error GoTo DelRecErr

  If MsgBox(MSG3, vbYesNo + vbQuestion) = vbYes Then
    mrsFormRecordset.Delete
    If gbTransPending Then gbDBChanged = True
    If mrsFormRecordset.EOF = False Then
      mrsFormRecordset.MoveNext
    End If
    mlNumRows = mlNumRows - 1
    DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
    mbDataChanged = False
  End If

  Exit Sub

DelRecErr:
  ShowError
End Sub

Private Sub cmdEdit_Click()
   On Error GoTo EditErr

  Dim nDelay As Long
  Dim nRetryCnt As Integer
  
  Screen.MousePointer = vbHourglass
RetryEdit:
   mrsFormRecordset.Edit
   lblStatus.Caption = MSG4
   mbEditFlag = True
   txtFieldData(0).SetFocus
   mvBookMark = mrsFormRecordset.Bookmark

   picChangeButtons.Visible = True
   picViewButtons.Visible = False
   cmdNext.Enabled = False
   cmdFirst.Enabled = False
   cmdLast.Enabled = False
   cmdPrevious.Enabled = False
   
   Screen.MousePointer = vbDefault
   Exit Sub

EditErr:
  If Err = 3260 And nRetryCnt < gnMURetryCnt Then
    nRetryCnt = nRetryCnt + 1
    DBEngine.Idle dbFreeLocks
    'Wait gnMUDelay seconds
    nDelay = Timer
    While Timer - nDelay < gnMUDelay
      'do nothing
    Wend
    Resume RetryEdit
  Else
    ShowError
  End If
End Sub

Private Sub cmdFilter_Click()
  On Error GoTo FilterErr

  Dim sFilter As String
  Dim frmDyn As New frmDynaSnap

  sFilter = InputBox(MSG5)
  If Len(sFilter) = 0 Then Exit Sub

  gsTableDynaFilter = "select * from " & AddBrackets(msTableName) & " where " & sFilter
  frmDyn.Show                           'open recordset form w/ filtered table
  gsTableDynaFilter = vbNullString
  
  Exit Sub

FilterErr:
  ShowError
End Sub

Private Sub cmdFirst_Click()
   On Error GoTo GoFirstError

   mrsFormRecordset.MoveFirst
   DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
   mbDataChanged = False

   Screen.MousePointer = vbDefault
   MsgBar vbNullString, False
   Exit Sub

GoFirstError:
   ShowError
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyF1 And Shift = 0 Then
    DisplayTopic 2016145
  End If
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  If mbEditFlag Or mbAddNewFlag Then Exit Sub
  
  Select Case KeyCode
    Case 35                'end
      Call cmdLast_Click
    Case 36                'home
      Call cmdFirst_Click
    Case 38                'up arrow
      If Shift = 2 Then
        Call cmdFirst_Click
      Else
        Call cmdPrevious_Click
      End If
    Case 40                'down arrow
      If Shift = 2 Then
        Call cmdLast_Click
      Else
        Call cmdNext_Click
      End If

  End Select

End Sub

Private Sub Form_Load()
    'ResMe autogenerated line of code to call the initialization routine that was automatically generated.
    Call frmTableObj_Auto_Init
   Dim nFieldType As Integer
   Dim i As Integer
   Dim tdf As TableDef
   Dim idx As Index
   Dim sIndex As String

   On Error GoTo TableErr

   cmdAdd.Caption = BUTTON1
   cmdEdit.Caption = BUTTON2
   cmdDelete.Caption = BUTTON3
   cmdClose.Caption = BUTTON4
   cmdSeek.Caption = BUTTON5
   cmdFilter.Caption = BUTTON6
   cmdCancel.Caption = BUTTON7
   cmdUpdate.Caption = BUTTON8
   lblFieldHdr.Caption = Label1
   lblFieldValue.Caption = Label2
   
   Screen.MousePointer = vbHourglass
   MsgBar MSG6, True

   msTableName = mrsFormRecordset.Name
   Set tdf = gdbCurrentDB.TableDefs(msTableName)
   For Each idx In tdf.Indexes
     sIndex = idx.Name
     sIndex = sIndex & ":" & idx.Fields
     If idx.Unique Then
       sIndex = sIndex & ":Unique"
     Else
       sIndex = sIndex & ":Non-Unique"
     End If
     If idx.Primary Then
       sIndex = sIndex & ":Primary"
     End If
     cboIndexes.AddItem sIndex
   Next
   
   'set the locking type
   If gsDataType = gsMSACCESS Then
     mrsFormRecordset.LockEdits = gnMULocking
   End If

   'show the first record
   mlNumRows = mrsFormRecordset.RecordCount

   'load the controls on the Table form
   lblFieldName(0).Visible = True
   txtFieldData(0).Visible = True
   nFieldType = mrsFormRecordset.Fields(0).Type
   txtFieldData(0).Width = GetFieldWidth(nFieldType)
   txtFieldData(0).TabIndex = 0
   If nFieldType = dbText Then txtFieldData(0).MaxLength = mrsFormRecordset.Fields(0).Size
   For i = 1 To mrsFormRecordset.Fields.Count - 1
     picFields.Height = picFields.Height + gnCTLARRAYHEIGHT
     Load lblFieldName(i)
     lblFieldName(i).Top = lblFieldName(i - 1).Top + gnCTLARRAYHEIGHT
     lblFieldName(i).Visible = True
     Load txtFieldData(i)
     txtFieldData(i).Top = txtFieldData(i - 1).Top + gnCTLARRAYHEIGHT
     txtFieldData(i).Visible = True
     nFieldType = mrsFormRecordset.Fields(i).Type
     txtFieldData(i).Width = GetFieldWidth(nFieldType)
     txtFieldData(i).TabIndex = i
     If nFieldType = dbText Then txtFieldData(i).MaxLength = mrsFormRecordset(i).Size
   Next

   'resize main window
   If i <= 10 Then
     Me.Height = ((i + 1) * gnCTLARRAYHEIGHT) + 1600
   Else
     Me.Height = 4668
     Me.Width = Me.Width + 260
     vsbScrollBar.Visible = True
     vsbScrollBar.Min = 900
     vsbScrollBar.Max = 900 - (i * gnCTLARRAYHEIGHT&) + 2500
   End If

   'display the field names
   For i = 0 To mrsFormRecordset.Fields.Count - 1
     lblFieldName(i).Caption = mrsFormRecordset(i).Name & ":"
   Next

   If cboIndexes.ListCount > 0 Then
     cboIndexes.ListIndex = 0
   Else
     DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
     mbDataChanged = False
   End If

   Me.Width = 5508
   Me.Left = 1000
   Me.Top = 1000
   
   Screen.MousePointer = vbDefault
   MsgBar vbNullString, False
   Exit Sub

TableErr:
   ShowError
   Unload Me
End Sub

Private Sub Form_Resize()
  On Error Resume Next

  Dim nHeight As Integer
  Dim i As Integer
  Dim nTotWidth As Integer

  If WindowState <> 1 Then   'not minimized
    MsgBar MSG7, True
    'make sure the form is lined up on a field
    nHeight = Me.Height
    If (nHeight - 1660) Mod gnCTLARRAYHEIGHT <> 0 Then
      Me.Height = ((nHeight - 1660) \ gnCTLARRAYHEIGHT) * gnCTLARRAYHEIGHT + 1660
    End If
    'resize the status bar
    picStatBox.Top = Me.Height - 650
    'resize the scrollbar
    vsbScrollBar.Height = picStatBox.Top - (picViewButtons.Top - picFieldHeader.Height) - 1200
    vsbScrollBar.Left = Me.Width - 360
    If mrsFormRecordset.Fields.Count > 10 Then
      picFields.Width = Me.Width - 260
      nTotWidth = vsbScrollBar.Left - 20
    Else
      picFields.Width = Me.Width - 20
      nTotWidth = Me.Width - 50
    End If
    picFieldHeader.Width = Me.Width - 20
    'widen the fields if possible
    For i = 0 To mrsFormRecordset.Fields.Count - 1
      lblFieldName(i).Width = 0.3 * nTotWidth
      txtFieldData(i).Left = lblFieldName(i).Width + 20
      If mrsFormRecordset(i).Type = dbText Or mrsFormRecordset(i).Type = dbMemo Then
        txtFieldData(i).Width = 0.7 * nTotWidth - 250
      End If
    Next
    lblFieldValue.Left = txtFieldData(0).Left
    lblStatus.Width = Me.Width - 1600
    cmdNext.Left = lblStatus.Width + 745
    cmdLast.Left = cmdNext.Left + 370
  End If
  MsgBar vbNullString, False
End Sub

Private Sub Form_Unload(Cancel As Integer)
  On Error Resume Next

  Unload mfrmSeek   'get rid of attached seek form
  mrsFormRecordset.Close          'close the form Table
  DBEngine.Idle dbFreeLocks
  MsgBar vbNullString, False
End Sub

Private Sub cmdLast_Click()
   On Error GoTo GoLastError

   mrsFormRecordset.MoveLast
   'show the current record
   DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
   mbDataChanged = False

   Exit Sub

GoLastError:
   ShowError
End Sub

Private Sub cmdNext_Click()
   On Error GoTo GoNextError

   mrsFormRecordset.MoveNext
   'show the current record
   DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
   mbDataChanged = False

   Exit Sub

GoNextError:
   ShowError
End Sub

Private Sub cmdPrevious_Click()
   On Error GoTo GoPrevError

   mrsFormRecordset.MovePrevious
   'show the current record
   DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
   mbDataChanged = False

   Exit Sub

GoPrevError:
   ShowError
End Sub

Private Sub cmdSeek_Click()
  On Error GoTo SeekErr
  
  Dim sBookMark As String

  If mrsFormRecordset.RecordCount = 0 Then Exit Sub

SeekStart:
  MsgBar MSG8, False
  frmSeek.Show vbModal
  If Len(gsSeekValue) = 0 Then
    MsgBar vbNullString, False
    Exit Sub
  End If

  sBookMark = mrsFormRecordset.Bookmark

  Screen.MousePointer = vbHourglass
  mrsFormRecordset.Seek gsSeekOperator, gsSeekValue
  Screen.MousePointer = vbDefault

  'return to old record if no match was found
  If mrsFormRecordset.NoMatch And Len(sBookMark) > 0 Then
    Beep
    MsgBox MSG9, 48
    mrsFormRecordset.Bookmark = sBookMark
    GoTo SeekStart
  End If

  DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
  mbDataChanged = False
  MsgBar vbNullString, False
  Exit Sub

SeekErr:
  Screen.MousePointer = vbDefault
  MsgBox Error
  Exit Sub
  
End Sub

Private Sub cmdUpdate_Click()
  On Error GoTo UpdateErr

  Dim nDelay As Long
  Dim nRetryCnt As Integer

  Screen.MousePointer = vbHourglass
RetryUpd:
  mrsFormRecordset.Update
  If gbTransPending Then gbDBChanged = True

  If mbAddNewFlag Then
    mlNumRows = mlNumRows + 1
    mrsFormRecordset.MoveLast               'move to the new record
  End If

  mbEditFlag = False
  mbAddNewFlag = False
  picChangeButtons.Visible = False
  picViewButtons.Visible = True
  cmdNext.Enabled = True
  cmdFirst.Enabled = True
  cmdLast.Enabled = True
  cmdPrevious.Enabled = True
  DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
  mbDataChanged = False

  DBEngine.Idle dbFreeLocks
  Screen.MousePointer = vbDefault
  Exit Sub

UpdateErr:
  If Err = 3260 And nRetryCnt < gnMURetryCnt Then
    nRetryCnt = nRetryCnt + 1
    mrsFormRecordset.Bookmark = mrsFormRecordset.Bookmark   'Cancel the update
    DBEngine.Idle dbFreeLocks
    nDelay = Timer
    'Wait gnMUDelay seconds
    While Timer - nDelay < gnMUDelay
      'do nothing
    Wend
    Resume RetryUpd
  Else
    ShowError
  End If
End Sub


'*********************************************************************************
'**          This Section Of Code Was Automatically Generated By ResMe          **
'**                                                                             **
'** String assignments to Constants have been converted to read-only properties **
'*********************************************************************************


'This was: Const BUTTON1 = "&Add"
Property Get BUTTON1 As String
    BUTTON1 = "&Add"
End Property

'This was: Const BUTTON2 = "&Edit"
Property Get BUTTON2 As String
    BUTTON2 = "&Edit"
End Property

'This was: Const BUTTON3 = "&Delete"
Property Get BUTTON3 As String
    BUTTON3 = "&Delete"
End Property

'This was: Const BUTTON4 = "&Close"
Property Get BUTTON4 As String
    BUTTON4 = "&Close"
End Property

'This was: Const BUTTON5 = "&Seek"
Property Get BUTTON5 As String
    BUTTON5 = "&Seek"
End Property

'This was: Const BUTTON6 = "F&ilter"
Property Get BUTTON6 As String
    BUTTON6 = "F&ilter"
End Property

'This was: Const BUTTON7 = "&Cancel"
Property Get BUTTON7 As String
    BUTTON7 = "&Cancel"
End Property

'This was: Const BUTTON8 = "&Update"
Property Get BUTTON8 As String
    BUTTON8 = "&Update"
End Property

'This was: Const Label1 = "Field NAme:"
Property Get Label1 As String
    Label1 = "Field NAme:"
End Property

'This was: Const Label2 = "Value (F4=Zoom)"
Property Get Label2 As String
    Label2 = "Value (F4=Zoom)"
End Property

'This was: Const MSG1 = "Add record"
Property Get MSG1 As String
    MSG1 = "Add record"
End Property

'This was: Const MSG2 = "Field Length Exceeded, Data Truncated!"
Property Get MSG2 As String
    MSG2 = "Field Length Exceeded, Data Truncated!"
End Property

'This was: Const MSG3 = "Delete Current Record?"
Property Get MSG3 As String
    MSG3 = "Delete Current Record?"
End Property

'This was: Const MSG4 = "Edit record"
Property Get MSG4 As String
    MSG4 = "Edit record"
End Property

'This was: Const MSG5 = "Enter Filter Expression:"
Property Get MSG5 As String
    MSG5 = "Enter Filter Expression:"
End Property

'This was: Const MSG6 = "Opening Table"
Property Get MSG6 As String
    MSG6 = "Opening Table"
End Property

'This was: Const MSG7 = "Resizing Form"
Property Get MSG7 As String
    MSG7 = "Resizing Form"
End Property

'This was: Const MSG8 = "Enter Seek Parameters"
Property Get MSG8 As String
    MSG8 = "Enter Seek Parameters"
End Property

'This was: Const MSG9 = "Record Not Found"
Property Get MSG9 As String
    MSG9 = "Record Not Found"
End Property


Private Sub frmTableObj_Auto_Init()
'This routine initializes all User Interface control properties on frmTableObj.
'This section of code was automatically generated by the ResMe String Extraction Utility.
    Me.Caption = "Table Object"
    cmdSeek.Caption = "&Seek"
    cmdFilter.Caption = "F&ilter"
    cmdClose.Caption = "&Close"
    cmdDelete.Caption = "&Delete"
    cmdEdit.Caption = "&Edit"
    cmdAdd.Caption = "&Add"
    lblIndex.Caption = "Index:"
    lblFieldValue.Caption = " Value  (F4=Zoom) "
    lblFieldHdr.Caption = "Field Name:"
    cmdUpdate.Caption = "&Update"
    cmdCancel.Caption = "&Cancel"
End Sub