f_zhibanjinglizhiban.frm

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

                     Format          =   ""
                     HaveTrueFalseNull=   0
                     FirstDayOfWeek  =   0
                     FirstWeekOfYear =   0
                     LCID            =   2052
                     SubFormatType   =   0
                  EndProperty
               EndProperty
               SplitCount      =   1
               BeginProperty Split0 
                  BeginProperty Column00 
                     ColumnWidth     =   1739.906
                  EndProperty
                  BeginProperty Column01 
                     ColumnWidth     =   1739.906
                  EndProperty
                  BeginProperty Column02 
                     ColumnWidth     =   915.024
                  EndProperty
                  BeginProperty Column03 
                     ColumnWidth     =   1739.906
                  EndProperty
                  BeginProperty Column04 
                     ColumnWidth     =   1800
                  EndProperty
               EndProperty
            End
            Begin VB.Label lblLabels 
               Caption         =   "值班编号:"
               Height          =   255
               Index           =   8
               Left            =   3000
               TabIndex        =   32
               Top             =   240
               Width           =   735
            End
            Begin VB.Label Label1 
               Caption         =   "检查项目"
               Height          =   255
               Left            =   240
               TabIndex        =   27
               Top             =   3840
               Width           =   975
            End
            Begin VB.Label lblLabels 
               Caption         =   "分析意见:"
               Height          =   255
               Index           =   7
               Left            =   240
               TabIndex        =   14
               Top             =   3000
               Width           =   855
            End
            Begin VB.Label lblLabels 
               Caption         =   "重要情节:"
               Height          =   255
               Index           =   6
               Left            =   240
               TabIndex        =   12
               Top             =   1920
               Width           =   735
            End
            Begin VB.Label lblLabels 
               Caption         =   "特别目标:"
               Height          =   255
               Index           =   5
               Left            =   240
               TabIndex        =   10
               Top             =   960
               Width           =   735
            End
            Begin VB.Label lblLabels 
               Caption         =   "结束时间:"
               Height          =   255
               Index           =   4
               Left            =   5760
               TabIndex        =   9
               Top             =   600
               Width           =   855
            End
            Begin VB.Label lblLabels 
               Caption         =   "开始时间:"
               Height          =   255
               Index           =   3
               Left            =   3000
               TabIndex        =   8
               Top             =   600
               Width           =   855
            End
            Begin VB.Label lblLabels 
               Caption         =   "部门经理:"
               Height          =   255
               Index           =   2
               Left            =   240
               TabIndex        =   6
               Top             =   600
               Width           =   735
            End
            Begin VB.Label lblLabels 
               Caption         =   "部门:"
               Height          =   255
               Index           =   1
               Left            =   5760
               TabIndex        =   4
               Top             =   240
               Width           =   615
            End
            Begin VB.Label lblLabels 
               Caption         =   "日期:"
               Height          =   255
               Index           =   0
               Left            =   240
               TabIndex        =   3
               Top             =   240
               Width           =   855
            End
         End
      End
   End
End
Attribute VB_Name = "F_ZhiBanJingLiZhiBan"
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 Form_Load()
On Error Resume Next
    For Each TextBox In Me.Controls
        
        
    Next
Dim oText As TextBox
  
 
  
  Set adoPrimaryRS = New Recordset
  adoPrimaryRS.Open "SHAPE {select 值班编号,日期,部门,部门经理,开始时间,结束时间,特别目标,重要情节,分析意见 from 值班经理值班标识} AS ParentCMD APPEND ({select 值班编号,检查部门,检查项目,检查次数,检查结果,备注 from 值班经理值班细目 } AS ChildCMD RELATE 值班编号 TO 值班编号) AS ChildCMD", db1, adOpenStatic, adLockBatchOptimistic

   
  '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
   Set DTPicker3.DataSource = adoPrimaryRS
   
   
  Set DataGrid1.DataSource = adoPrimaryRS
  
  SetButtons True
If Not adoPrimaryRS.EOF 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
   DTPicker3.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
End Sub

Private Sub txtFields_LostFocus(Index As Integer)
If Index = 1 And IsNull(txtFields(0).Text) Then
  txtFields(0).Locked = True
End If
End Sub