dataform.frm

汽修厂管理软件

    Case vbDataActionMoveLast
      '什么也不做
    Case vbDataActionAddNew
      '什么也不做
    Case vbDataActionUpdate
       '移到 cmdUpdate_click 事件代码
    Case vbDataActionDelete
      '什么也不做
    Case vbDataActionFind
      '设置 reposition 事件中使用的标志
      mbJustUsedFind = True
    Case vbDataActionBookmark
      '什么也不做"
    Case vbDataActionClose, vbDataActionUnload
      If Save Then
        If MsgBox(MSG6, mnMSGBOX_TYPE) <> vbYes Then
          Save = False
        End If
      End If

  End Select

  Exit Sub

ValErr:
  ShowErrMsg
  Exit Sub
  
End Sub

Private Sub cmdDelete_Click()
  On Error GoTo DELErr

  If MsgBox(MSG7, mnMSGBOX_TYPE) = vbYes Then
    datDataCtl.Recordset.Delete
    mlNumRows = mlNumRows - 1
    datDataCtl.Recordset.MoveNext
    '如果发生 EOF，移开这种情况
    If datDataCtl.Recordset.RecordCount > 0 Then datDataCtl.Recordset.MoveLast
    maFldArr(0).SetFocus
  End If

  Exit Sub

DELErr:
  ShowErrMsg
  Exit Sub

End Sub

Private Sub cmdFind_Click()
  On Error GoTo FindErr

  Dim sBookMark As String
  Dim sFindStr As String

  If datDataCtl.Recordset.Type = dbOpenTable Then
    sFindStr = InputBox(MSG8)
  Else
    sFindStr = InputBox(MSG9)
  End If
  If Len(sFindStr) = 0 Then Exit Sub

  If datDataCtl.Recordset.RecordCount > 0 Then
    sBookMark = datDataCtl.Recordset.Bookmark
  End If

  If datDataCtl.Recordset.Type = dbOpenTable Then
    datDataCtl.Recordset.Seek "=", sFindStr
  Else
    datDataCtl.Recordset.FindFirst sFindStr
  End If

  '如果匹配未找到，返回旧的记录
  If datDataCtl.Recordset.NoMatch And Len(sBookMark) > 0 Then
    datDataCtl.Recordset.Bookmark = sBookMark
  End If

  maFldArr(1).SetFocus
  Exit Sub

FindErr:
  ShowErrMsg
  maFldArr(1).SetFocus
  Exit Sub

End Sub

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

Private Sub Form_Load()
'  On Error GoTo LoadErr

  cmdCancelAdd.Caption = BUTTON1
  cmdUpdate.Caption = BUTTON2
  cmdDelete.Caption = BUTTON3
  cmdFind.Caption = BUTTON4
  cmdRefresh.Caption = BUTTON5
  cmdClose.Caption = BUTTON6
  cmdAdd.Caption = BUTTON7
 ' lblFieldHeader.Caption = Label1
  'lblFieldValue.Caption = Label2
  
  'mrsFormRecordset 是一个全局模块级变量
  '必须在显示（Show）这个窗体之前设置好
  
  
  With mrsFormRecordset
    If .Type = dbOpenTable Then
      '需要设置索引
       If DBSGRG.TableDefs(.Name).Indexes.Count > 0 Then
        .Index = DBSGRG.TableDefs(.Name).Indexes(0).Name
      End If
    End If
    If .RecordCount > 0 Then
      '移到下一个，然后移到前一个，得到记录数
      .MoveLast
      .MoveFirst
    End If
  End With
  Set datDataCtl.Recordset = mrsFormRecordset
  
  Me.Width = 5868
  loadFields
  Me.Show
  If maFldArr(0).Enabled = False Then
    maFldArr(1).SetFocus
   Else
    maFldArr(0).SetFocus
  End If
  Exit Sub

LoadErr:
  ShowErrMsg
 ' Unload Me
End Sub

Private Sub Form_Resize()
 ' On Error Resume Next

  'If gbSettingDataCtl Then Exit Sub
  'If mbResizing Then Exit Sub

  Dim nHeight As Integer
  Dim i As Integer
  Dim nTotalWidth As Integer

  mbResizing = True
  If Me.WindowState <> 1 And lblFieldName(0).Visible Then '非最小化的
    '确保窗体在一个范围内排列整齐
    nHeight = Me.Height
    If (nHeight - 1320) Mod mnCTLARRAYHEIGHT <> 0 Then
      Me.Height = ((nHeight - 1280) \ mnCTLARRAYHEIGHT) * mnCTLARRAYHEIGHT + 1280
    End If
    '改变状态栏的大小
    datDataCtl.Top = Me.Height - 650
    '改变状态栏的大小
    vsbScrollBar.Height = Me.Height - 1300
    vsbScrollBar.Left = Me.Width - 360
    If mrsFormRecordset.Fields.Count > 10 Then
      picFields.Width = Me.Width - 260
      nTotalWidth = vsbScrollBar.Left - 20
    Else
      picFields.Width = Me.Width - 20
      nTotalWidth = Me.Width - 50
    End If
   ' picButtons.Width = Me.Width - 20
    '如果可能的话加宽字段
    For i = 0 To mrsFormRecordset.Fields.Count - 1
      lblFieldName(i).Width = 0.3 * nTotalWidth - 100
      maFldArr(i).Left = lblFieldName(i).Width + 200
      If datDataCtl.Recordset.Fields(i).Type > 10 Then
        maFldArr(i).Width = 0.7 * nTotalWidth - 270
         End If
    Next
    'lblFieldValue.Left = maFldArr(0).Left

  End If

  mbResizing = False

End Sub

Private Function GetFieldWidth(rnType As Integer, FieldSize As Integer)
  '决定基于字段类型确定窗体控件的宽度
  Select Case rnType
    Case dbBoolean
      GetFieldWidth = 850
    Case dbByte
      GetFieldWidth = 650
    Case dbInteger
      GetFieldWidth = 900
    Case dbLong
      GetFieldWidth = 1100
    Case dbCurrency
      GetFieldWidth = 1800
    Case dbSingle
      GetFieldWidth = 1800
    Case dbDouble
      GetFieldWidth = 2200
    Case dbDate
      GetFieldWidth = 2000
    Case dbText
      
      GetFieldWidth = 100 * FieldSize
      If GetFieldWidth > 3250 Then GetFieldWidth = 3250
    Case dbMemo
      GetFieldWidth = 3250
    Case Else
      GetFieldWidth = 3250
  End Select

End Function

Private Sub loadFields()
   Dim recTmp As Recordset
   Dim nFldType As Integer
   Dim nFieldSize As Integer
   Dim i As Integer

  ' On Error GoTo LoadFieldsErr

   Set mrsFormRecordset = datDataCtl.Recordset
   Set recTmp = mrsFormRecordset

   '加载记录集窗体上的控件
   mnNumFields = recTmp.Fields.Count
   ReDim maFldArr(mnNumFields) As Object
   lblFieldName(0).Visible = True
   nFldType = recTmp.Fields(0).Type
   
   nFieldSize = recTmp.Fields(0).Size
   If nFldType = dbBoolean Then
     Set maFldArr(0) = chkFieldData(0)
   ElseIf nFldType = dbLongBinary Then
     If datDataCtl.Tag = "OLE" Then
     
     Else
       Set maFldArr(0) = picFieldData(0)
     End If
   Else
      
     Set maFldArr(0) = txtFieldData(0)
     
   End If
    maFldArr(0).Visible = True
   maFldArr(0).Top = 0
   maFldArr(0).Width = GetFieldWidth(nFldType, nFieldSize)
  If recTmp.Fields(0).Name = "ID" Or recTmp.Fields(0).Name = "Id" Then
    maFldArr(0).Enabled = False
  End If
   If nFldType = dbText Then maFldArr(0).MaxLength = recTmp.Fields(0).Size

   maFldArr(0).TabIndex = 0
   On Error Resume Next
   For i = 1 To recTmp.Fields.Count - 1
     picFields.Height = picFields.Height + mnCTLARRAYHEIGHT
     Load lblFieldName(i)
     lblFieldName(i).Top = lblFieldName(i - 1).Top + mnCTLARRAYHEIGHT
     lblFieldName(i).Visible = True
     nFldType = recTmp.Fields(i).Type
      nFieldSize = recTmp.Fields(i).Size

     If nFldType = dbBoolean Then
       Load chkFieldData(i)
       Set maFldArr(i) = chkFieldData(i)
     ElseIf nFldType = dbLongBinary Then
       If datDataCtl.Tag = "OLE" Then
         Else
         Load picFieldData(i)
         Set maFldArr(i) = picFieldData(i)
       End If
     Else
       Select Case recTmp.Fields(i).Name
       Case "工组"
          Load CombFieldData(i)
          Set maFldArr(i) = CombFieldData(i)
          maFldArr(i).AddItem "美容班"
          maFldArr(i).AddItem "机修班"
          maFldArr(i).AddItem "电路板"
          maFldArr(i).AddItem "砂钣班"
          maFldArr(i).AddItem "管理"
       Case "资质"
          Load CombFieldData(i)
          Set maFldArr(i) = CombFieldData(i)
          maFldArr(i).AddItem "技师"
          maFldArr(i).AddItem "中工"
          maFldArr(i).AddItem "小工"
          maFldArr(i).AddItem "管理人员"
       Case "班组"
       
          Load CombFieldData(i)
          Set maFldArr(i) = CombFieldData(i)
          maFldArr(i).AddItem "美容班"
          maFldArr(i).AddItem "机修班"
          maFldArr(i).AddItem "电路板"
          maFldArr(i).AddItem "砂板班"
          maFldArr(i).AddItem "管理"
       
       Case Else
          Load txtFieldData(i)
          Set maFldArr(i) = txtFieldData(i)
       End Select
    End If
     maFldArr(i).Top = maFldArr(i - 1).Top + mnCTLARRAYHEIGHT
     maFldArr(i).Visible = True
     maFldArr(i).Enabled = True
     If GetFieldWidth(nFldType, nFieldSize) > 1000 Then
      maFldArr(i).Width = GetFieldWidth(nFldType, nFieldSize)
     Else
      maFldArr(i).Width = 1000
     End If
     maFldArr(i).TabIndex = i
     If nFldType = dbText Then maFldArr(i).MaxLength = recTmp.Fields(i).Size
   Next

   On Error GoTo LoadFieldsErr

   '重新调整主窗口
   picFields.Top = picButtons.Top + picButtons.Height
   mnFieldTop = picFields.Top
   vsbScrollBar.Value = mnFieldTop
   If i <= 10 Then
     Height = i * mnCTLARRAYHEIGHT + 1500
     vsbScrollBar.Visible = False
   Else
     Height = 4500
     Width = Width + 260
     vsbScrollBar.Visible = True
     vsbScrollBar.Min = mnFieldTop
     vsbScrollBar.Max = mnFieldTop - (i * mnCTLARRAYHEIGHT) + 3000
   End If

   '显示字段名称
   For i = 0 To recTmp.Fields.Count - 1
     lblFieldName(i).Caption = recTmp.Fields(i).Name & ":"
   
   Next
   
   '绑定控件
   On Error Resume Next   '尽管表是空的也要绑定
   For i = 0 To recTmp.Fields.Count - 1
     maFldArr(i).DataField = recTmp.Fields(i).Name
   Next

   Exit Sub

LoadFieldsErr:
   ShowErrMsg
   Exit Sub

End Sub

Private Sub cmdRefresh_Click()
  On Error GoTo RefErr

  If mbIsParameterized Then
    MsgBox MSG13, vbInformation
    Exit Sub
  End If
  
  datDataCtl.Refresh
  Exit Sub
  If cmdCancelAdd.Visible = True Then
    cmdCancelAdd.Visible = False
    cmdAdd.Visible = True
  End If
RefErr:
  ShowErrMsg
End Sub

Private Sub SetRecNum()
'  On Error GoTo SRErr
  
  Dim sCurrStat As String
  Dim lCurrRec As Long
  Dim bNoInd As Integer
  
  '得到当前记录数
  mlNumRows = datDataCtl.Recordset.RecordCount
  
  If datDataCtl.EditMode <> dbEditAdd Then
    If datDataCtl.Recordset.BOF Then
      sCurrStat = "(BOF)/" & mlNumRows
    ElseIf datDataCtl.Recordset.EOF Then
      sCurrStat = "(EOF)/" & mlNumRows
    Else
      '检查是否没有索引的表正在使用
      If datDataCtl.Recordset.Type = dbOpenTable Then
        If datDataCtl.Database(datDataCtl.RecordSource).Indexes.Count = 0 Then
          bNoInd = True
        End If
      End If
      '如果表没有索引或记录集是仅向前类型的，
      'PercentPosition 就不能使用
      If bNoInd Then
        sCurrStat = mlNumRows & MSG10
      ElseIf (datDataCtl.Options And dbForwardOnly) = dbForwardOnly Then
        sCurrStat = mlNumRows & MSG11
      Else
        lCurrRec = (mlNumRows * (datDataCtl.Recordset.PercentPosition * 0.01)) + 1
        sCurrStat = lCurrRec & "/" & mlNumRows
      End If
    End If
    If datDataCtl.Recordset.Updatable = False Then
      sCurrStat = sCurrStat & MSG12
      cmdAdd.Enabled = False
      cmdCancelAdd.Enabled = False
      cmdUpdate.Enabled = False
      cmdDelete.Enabled = False
    Else
      cmdAdd.Enabled = True
      cmdCancelAdd.Enabled = True
      cmdUpdate.Enabled = True
      cmdDelete.Enabled = True
    End If
    datDataCtl.Caption = sCurrStat
  End If

  '如果需要的话重新设置按钮
  If datDataCtl.EditMode <> dbEditAdd Then
    cmdCancelAdd.Visible = False
    cmdAdd.Visible = True
  End If

  Exit Sub
SRErr:
  If Err <> 3021 Then
    ShowErrMsg
  End If
  Exit Sub

End Sub

Private Sub cmdUpdate_Click()
  On Error GoTo UpdErr

  Dim bAddFlag As Integer

  Dim nDelay As Long
  Dim nRetryCnt As Integer

  bAddFlag = datDataCtl.EditMode
  
  If datDataCtl.EditMode = dbEditAdd Then
    If MsgBox(MSG4, mnMSGBOX_TYPE) = vbYes Then
      Screen.MousePointer = vbHourglass
RetryUpd1:
      datDataCtl.UpdateRecord
      mlNumRows = mlNumRows + 1
    End If
  Else
    If MsgBox(MSG5, mnMSGBOX_TYPE) = vbYes Then
      Screen.MousePointer = vbHourglass
RetryUpd2:
      datDataCtl.UpdateRecord
    End If
  End If

  If bAddFlag = dbEditAdd Then
    mrsFormRecordset.MoveLast
  End If
  If cmdCancelAdd.Visible = True Then
    cmdCancelAdd.Visible = False
    cmdAdd.Visible = True
  End If
  
  DBEngine.Idle dbFreeLocks
  Screen.MousePointer = vbDefault
  
  Exit Sub

UpdErr:
 ' If Err = 3260 And nRetryCnt < gnMURetryCnt Then
  '  nRetryCnt = nRetryCnt + 1
   ' datDataCtl.Recordset.Bookmark = datDataCtl.Recordset.Bookmark   '取消更新
   ' DBEngine.Idle dbFreeLocks
   ' nDelay = Timer
    '等待 gnMUDelay 秒
   ' While Timer - nDelay < gnMUDelay
      '什么也不做
   ' Wend
   ' If datDataCtl.EditMode = dbEditAdd Then
    '  Resume RetryUpd1
    'Else
     ' Resume RetryUpd2
    'End If
  'Else
   ' Screen.MousePointer = vbDefault
   ' ShowErrMsg
    'Exit Sub
  'End If

End Sub

Private Sub ShowErrMsg()
  MsgBox "Error:" & Err & " " & Error
End Sub