f_baodandengji.frm

行政管理系统商业源码,可以down下来看看

            End
            Begin VB.Label lblLabels 
               Caption         =   "保单号:"
               Height          =   255
               Index           =   0
               Left            =   240
               TabIndex        =   3
               Top             =   360
               Width           =   1215
            End
         End
      End
   End
End
Attribute VB_Name = "F_BaoDanDengJi"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim WithEvents adoPrimaryRS As Recordset
Attribute adoPrimaryRS.VB_VarHelpID = -1
Dim mvBookMark As Variant
Dim mbEditFlag As Boolean
Dim mbAddNewFlag As Boolean
Private Function UpdateData() As Boolean
  Dim strTemp As String
  Dim adochild As ADODB.Recordset
  On Error GoTo UpdateErr
  
  '更新父表
  adoPrimaryRS.UpdateBatch adAffectCurrent
 
  '检查子表的有效性
  Set adochild = New Recordset
  Set adochild = adoPrimaryRS("ChildCMD").UnderlyingValue
  
  If Not adochild.BOF Or Not adochild.EOF Then
    adochild.MoveFirst
  End If
  
  'While Not adochild.EOF

      
   '   If Trim(adochild.Fields("单价")) = "" Or IsNull(adochild.Fields("单价")) Or Not IsNumeric(adochild.Fields("单价")) Then
    '     MsgBox "请在单价中输入数字！", vbExclamation + vbOKOnly, "警告"
     '    adochild.Close
         '   Set adochild = Nothing
         'Exit Function
      'End If
      
      'If Trim(adochild.Fields("数量")) = "" Or IsNull(adochild.Fields("数量")) Or Not IsNumeric(adochild.Fields("单价")) Then
         '  MsgBox "请在数量中输入数字！", vbExclamation + vbOKOnly, "警告"
        ' adochild.Close
        ' Set adochild = Nothing
         'Exit Function
     ' End If
      
      
  '    adochild.MoveNext
 ' Wend
  
  '更新子表
  adochild.UpdateBatch adAffectAllChapters
  adochild.Close
  Set adochild = Nothing
  
 ' strTemp = txtFields(0).Text
 ' Set grdDataGrid.DataSource = Nothing
  'adoPrimaryRS.Requery
  'adoPrimaryRS.Find "目的港='" & strTemp & "'", 0, adSearchForward
  'Set grdDataGrid.DataSource = adoPrimaryRS("ChildCMD").UnderlyingValue
 
  UpdateData = True
  
  If mbAddNewFlag Then
    adoPrimaryRS.MoveLast              'move to the new record
  End If

  mbEditFlag = False
  mbAddNewFlag = False
  SetButtons True
  
  Exit Function

UpdateErr:
  UpdateData = False

End Function



Private Sub Adodc1_WillMove(ByVal adReason As ADODB.EventReasonEnum, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)

End Sub

Private Sub Form_Load()

  Set adoPrimaryRS = New Recordset
  adoPrimaryRS.Open "SHAPE {select 保单号,保单类别,投保开始时间,投保终止时间,保费,合同号,投保人数,保额,备注 from 保单登记} AS ParentCMD APPEND ({select 员工号,部门,姓名,性别,年龄,工种,健康情况,保额,保单号,备注 from 办公室人员投保登记 } AS ChildCMD RELATE 保单号 TO 保单号) AS ChildCMD", db1, adOpenStatic, adLockBatchOptimistic
  
  
  Set DataGrid1.DataSource = adoPrimaryRS
  
  SetButtons True

  
  Dim oText As TextBox
  'Bind the text boxes to the data provider
  For Each oText In Me.txtFields
    Set oText.DataSource = adoPrimaryRS
  Next
  
  Set DTPicker1.DataSource = adoPrimaryRS
  Set DTPicker2.DataSource = adoPrimaryRS

 If adoPrimaryRS.RecordCount <> 0 Then
  Set grdDataGrid.DataSource = adoPrimaryRS("ChildCMD").UnderlyingValue
 End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Screen.MousePointer = vbDefault
End Sub

Private Sub cmdAdd_Click()
  On Error GoTo AddErr

  
  
 With adoPrimaryRS
    If Not (.BOF And .EOF) Then
      mvBookMark = .Bookmark
    End If
    .AddNew

    mbAddNewFlag = True
    SetButtons False
  End With

  Exit Sub
AddErr:
  MsgBox "增加操作有错误", vbExclamation + vbOKOnly, pTitle
  
End Sub

Private Sub cmdDelete_Click()
 Dim adochild As ADODB.Recordset
  On Error GoTo DeleteErr
  Result = MsgBox("此操作将删除此记录所有信息，你真的要删除吗？", vbExclamation + vbYesNo + vbDefaultButton2, "提示")
  If Result = 6 Then                                    '选择YES
  
        '删除子表记录
        
       Set adochild = New Recordset
       Set adochild = adoPrimaryRS("ChildCMD").UnderlyingValue
       While Not adochild.EOF
            adochild.Delete
            adochild.MoveNext
       Wend
       adochild.UpdateBatch adAffectAll
       adochild.Close
       Set adochild = Nothing
       
       '删除父表的当前记录
       
       With adoPrimaryRS
         .Delete
         .UpdateBatch adAffectCurrent
         .MoveNext
         If .EOF Then .MoveLast
       End With
  End If
  Exit Sub
 
DeleteErr:
  MsgBox "删除数据错误！", vbExclamation + vbOKOnly, "Ptitle"
End Sub

Private Sub cmdRefresh_Click()
  'This is only needed for multi user apps
  On Error GoTo RefreshErr
  adoPrimaryRS.Requery
  Exit Sub
RefreshErr:
   MsgBox "刷新操作有错误", vbExclamation + vbOKOnly, pTitle
End Sub

Private Sub cmdEdit_Click()
  On Error GoTo EditErr
  mbEditFlag = True
  SetButtons False
  Exit Sub

EditErr:
   MsgBox "更改操作有错误", vbExclamation + vbOKOnly, pTitle
End Sub
Private Sub cmdCancel_Click()
 ' On Error Resume Next
 On Error GoTo CancelErr


  mbEditFlag = False
  mbAddNewFlag = False
  adoPrimaryRS.CancelUpdate

  If mvBookMark > 0 Then
   adoPrimaryRS.Bookmark = mvBookMark
  Else
   adoPrimaryRS.MoveFirst
  End If
 SetButtons True
  Exit Sub
CancelErr:
   
   MsgBox "取消操作有错误", vbExclamation + vbOKOnly, pTitle

End Sub

Private Sub cmdUpdate_Click()
 Dim blnUpdateFlag As Boolean
  blnUpdateFlag = UpdateData
  If blnUpdateFlag = True Then
    MsgBox "数据保存成功！", vbInformation + vbOKOnly, "提示"
  Else
    MsgBox "数据保存失败！", vbExclamation + vbOKOnly, "警告"
  End If
End Sub
Private Sub cmdClose_Click()
  XingZhengGL.Enabled = True
  Unload Me
End Sub

Private Sub SetButtons(bVal As Boolean)
 Dim oText As TextBox
 
  cmdAdd.Visible = bVal
  cmdEdit.Visible = bVal
  cmdUpdate.Visible = Not bVal
  cmdCancel.Visible = Not bVal
  cmdDelete.Visible = bVal
  cmdClose.Visible = bVal
  cmdRefresh.Visible = bVal
  If bVal Then
   Set DataGrid1.DataSource = adoPrimaryRS
  Else
   Set DataGrid1.DataSource = Nothing
  End If
   
 
  For Each oText In Me.txtFields
     oText.Enabled = Not bVal
  Next
  
   DTPicker1.Enabled = Not bVal
   DTPicker2.Enabled = Not bVal
   
   If mbEditFlag Then
    grdDataGrid.AllowAddNew = Not bVal
    grdDataGrid.AllowDelete = Not bVal
    grdDataGrid.AllowUpdate = Not bVal
   End If
End Sub




Private Sub grdDataGrid_Error(ByVal DataError As Integer, Response As Integer)
    Response = 0
    MsgBox "输入数据不合法，请输入合法数据！", vbExclamation + vbOKOnly, pTitle
End Sub

Private Sub txtFields_Change(Index As Integer)
If Not IsNumeric(txtFields(4).Text) And (txtFields(4).Text <> "") Then
    MsgBox "请在“保费”中输入数字", vbExclamation + vbOKOnly, pTitle
     txtFields(4).SetFocus
     txtFields(4).SelLength = Len(txtFields(4))
     txtFields(4).SelStart = 0
End If


If Not IsNumeric(txtFields(6).Text) And (txtFields(6).Text <> "") Then
    MsgBox "请在“投保人数”中输入数字", vbExclamation + vbOKOnly, pTitle
     txtFields(6).SetFocus
     txtFields(6).SelLength = Len(txtFields(6))
     txtFields(6).SelStart = 0
End If

If Not IsNumeric(txtFields(7).Text) And (txtFields(7).Text <> "") Then
    MsgBox "请在“保额”中输入数字", vbExclamation + vbOKOnly, pTitle
     txtFields(7).SetFocus
     txtFields(7).SelLength = Len(txtFields(7))
     txtFields(7).SelStart = 0
End If
End Sub

Private Sub txtFields_LostFocus(Index As Integer)
 grdDataGrid.Columns(0).Visible = False

End Sub