tableobj.frm

SQL数据库工具就是一种即可以进行数据浏览、添加、删除和修改等数据库管理操作

         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
    '等待 gnMUDelay 秒
    nDelay = Timer
    While Timer - nDelay < gnMUDelay
      '什么都不做
    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                           '用过滤的表打开记录集窗体
  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                '上箭头
      If Shift = 2 Then
        Call cmdFirst_Click
      Else
        Call cmdPrevious_Click
      End If
    Case 40                '下箭头
      If Shift = 2 Then
        Call cmdLast_Click
      Else
        Call cmdNext_Click
      End If

  End Select

End Sub

Private Sub Form_Load()
   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
   
   '设置锁定类型
   If gsDataType = gsMSACCESS Then
     mrsFormRecordset.LockEdits = gnMULocking
   End If

   '显示第一个记录
   mlNumRows = mrsFormRecordset.RecordCount

   '加载表窗体上的控件
   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

   '重新设置主窗口尺寸
   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

   '显示字段名称
   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   '非最小化
    MsgBar MSG7, True
    '确保窗体在一个区域内排列好
    nHeight = Me.Height
    If (nHeight - 1660) Mod gnCTLARRAYHEIGHT <> 0 Then
      Me.Height = ((nHeight - 1660) \ gnCTLARRAYHEIGHT) * gnCTLARRAYHEIGHT + 1660
    End If
    '改变状态栏的尺寸
    picStatBox.Top = Me.Height - 650
    '改变状态栏的尺寸
    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
    '如果可能的话加宽字段
    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   '卸掉附加的搜索窗体
  mrsFormRecordset.Close          '关闭窗体表
  DBEngine.Idle dbFreeLocks
  MsgBar vbNullString, False
End Sub

Private Sub cmdLast_Click()
   On Error GoTo GoLastError

   mrsFormRecordset.MoveLast
   '显示当前记录
   DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
   mbDataChanged = False

   Exit Sub

GoLastError:
   ShowError
End Sub

Private Sub cmdNext_Click()
   On Error GoTo GoNextError

   mrsFormRecordset.MoveNext
   '显示当前记录
   DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
   mbDataChanged = False

   Exit Sub

GoNextError:
   ShowError
End Sub

Private Sub cmdPrevious_Click()
   On Error GoTo GoPrevError

   mrsFormRecordset.MovePrevious
   '显示当前记录
   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

  '如果匹配未找到，返回到旧的记录上
  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               '移到新记录上
  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   '取消更新
    DBEngine.Idle dbFreeLocks
    nDelay = Timer
    '等待 gnMUDelay 秒
    While Timer - nDelay < gnMUDelay
      '什么都不做
    Wend
    Resume RetryUpd
  Else
    ShowError
  End If
End Sub