frmpublic.frm

针对矿山企业安全相关法律开发的企业考核评价系统

Attribute VB_Name = "FrmPublic"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim RS As Recordset
Private Type Class_Socre
        kpClass As String
        ActScore As Single
End Type
Dim VClassScore() As Class_Socre
Dim sum1 As Single
Dim sum2 As Single
Dim UnitScore As Single
Public TableName As String
Dim strReport As String
Private Sub cmdNext_Click()
RS.MoveNext
 If RS.EOF Then
    MsgBox "已经到记录末尾!"
    RS.MoveLast
 End If
 txtClass = Mid(RS.Fields("kpClass"), 2)
 txtItem = RS.Fields("kpItem")
 txtContent = RS.Fields("kpContent")
 txtStdScore = RS.Fields("StdScore")
 txtMethod = RS.Fields("kpMethod")
 If RS.Fields("NotInclude") Then
    Check1.Value = 1
 Else
    Check1.Value = 0
 End If
 If IsNull(RS.Fields("ActualScore")) Then
   txtActualScore = ""
 Else
   txtActualScore = RS.Fields("ActualScore")
 End If
 If IsNull(RS.Fields("Remark")) Then
    txtRemark = ""
 Else
    txtRemark = RS.Fields("Remark")
 End If
End Sub

Private Sub cmdPrevious_Click()
RS.MovePrevious
 If RS.BOF Then
    MsgBox "已经到记录头!"
    RS.MoveFirst
 End If
 txtClass = Mid(RS.Fields("kpClass"), 2)
 txtItem = RS.Fields("kpItem")
 txtContent = RS.Fields("kpContent")
 txtStdScore = RS.Fields("StdScore")
 txtMethod = RS.Fields("kpMethod")
 If RS.Fields("NotInclude") Then
    Check1.Value = 1
 Else
    Check1.Value = 0
 End If
 If IsNull(RS.Fields("ActualScore")) Then
   txtActualScore = ""
 Else
   txtActualScore = RS.Fields("ActualScore")
 End If
 If IsNull(RS.Fields("Remark")) Then
    txtRemark = ""
 Else
    txtRemark = RS.Fields("Remark")
 End If
End Sub

Private Sub cmdReportView_Click()
'考评类目中不存在的考评项目不参加考评。
'考评类目的考评实际得分＝
'（所有参与考评项目实际得分之和）×（所有考评项目标准分之和÷所有参与考评项目标准分之和）
'考评实际得分＝
'（所有参与考评类目的考评实际得分之和）×（所有考评类目标准分之和(=100)÷所有参与考评类目标准分之和）。
Dim ItemRS1 As Recordset, ItemRS2 As Recordset, ClassSumRS1 As Recordset, ClassSumRS2 As Recordset, TotalSumRS As Recordset, ErrEmptyRS As Recordset ' ClassNotIn As Recordset, ClassCountRS As Recordset,
Dim TempQdf As QueryDef
Dim i As Integer, j As Integer, SearchStr As String
'Set TempQdf = sysDB.CreateQueryDef("CommQdf")
Set TempQdf = sysDB.QueryDefs("CommQdf")
TempQdf.SQL = "Select kpClass,kpItem  From " & TableName & " Where ActualScore IS Null And NotInclude =False"
Set ErrEmptyRS = TempQdf.OpenRecordset
If Not ErrEmptyRS.BOF Then
    ErrEmptyRS.MoveFirst
    MsgBox "考评类目:" & ErrEmptyRS.Fields("kpClass") & "考评项目" & ErrEmptyRS.Fields("kpItem") & "， 没输入分数！"
    ErrEmptyRS.Close
    Set ErrEmptyRS = Nothing
    Exit Sub
End If

Set TempQdf = sysDB.QueryDefs("CommQdf")
TempQdf.SQL = "Select kpClass,kpItem,StdScore,ActualScore,Remark From " & TableName & " Where NotInclude=False"
Set ItemRS1 = TempQdf.OpenRecordset
TempQdf.SQL = "Select kpClass,kpItem,StdScore,ActualScore,Remark From " & TableName & " Where NotInclude=True"
Set ItemRS2 = TempQdf.OpenRecordset
'某类中所有参与考评项目标准分之和，所有参与考评项目实际得分之和
TempQdf.SQL = "Select kpClass,Sum(StdScore) As StdSum,Sum(ActualScore) As ActSum ,Count(*)  As ClassItemNum From " & TableName & " Where NotInclude=False Group By kpClass"
Set ClassSumRS1 = TempQdf.OpenRecordset
i = 0 '所有参评类目计数
Do While Not ClassSumRS1.EOF
    i = i + 1
    ClassSumRS1.MoveNext
Loop
If i > 0 Then 'ClassSumRS1 不为空,有参评项目!
    ReDim VClassScore(1 To i) As Class_Socre '报表小计中用到
Else
    MsgBox " 此单元没有参评项目!,得分为0 请核实!"
    UnitScore = 0
    Exit Sub
End If
'TempQdf.SQL = "Select kpClass,Sum(StdScore),Sum(ActualScore) From "& TableName &"  Group By kpClass Having Not(Sum(ActualScore) Is Null)"
'上面一条语句可能更有用；保险起见，未用！
TempQdf.SQL = "Select kpClass,Sum(StdScore) As StdSum  From " & TableName & " Group By kpClass "
'某类所有考评项目标准分之和
Set ClassSumRS2 = TempQdf.OpenRecordset
ClassSumRS1.MoveFirst
i = 1 '最后变更,原i =1
sum1 = 0
sum2 = 0

'遍历,ClassSumRS1找出每一参评(完全参评或不完全参评)类目的标准分
'计算每一个考评类目的实际得分和所有参与考评类目实际得分之和以及所有参与考评类目标准分之和
Do While Not ClassSumRS1.EOF
    SearchStr = ClassSumRS1.Fields("kpClass")
    ClassSumRS2.MoveFirst
    ClassSumRS2.FindFirst "kpClass ='" & SearchStr & "'"
    If ClassSumRS2.NoMatch Then
        MsgBox "SYSTEM ERROR！"
        Exit Sub
    'Else
    '    Debug.Print SearchStr, ClassSumRS2.Fields("kpclass")
    End If
    VClassScore(i).kpClass = SearchStr
    VClassScore(i).ActScore = ClassSumRS1.Fields("ActSum") * (ClassSumRS2.Fields("StdSum") / ClassSumRS1.Fields("StdSum")) '计算每一个考评类目的实际得分
    sum1 = sum1 + VClassScore(i).ActScore 'sum1所有参与考评类目实际得分之和
    sum2 = sum2 + ClassSumRS2.Fields("StdSum") 'sum2所有参与考评类目标准分之和
    i = i + 1
    ClassSumRS1.MoveNext
Loop
'TempQdf.SQL = "Select kpClass,Count(*)  From "& TableName &" Where NotInclude=False Group By kpClass "
'Set ClassCountRS = TempQdf.OpenRecordset
'
TempQdf.SQL = "Select Sum(StdScore) as TotalSum From " & TableName ' 所有考评类目标准分之和= 所有考评项目标准分之和
Set TotalSumRS = TempQdf.OpenRecordset '

UnitScore = sum1 * (TotalSumRS.Fields("TotalSum") / sum2) '单元实际得分
'Debug.Print UnitScore, sum1, sum2
'报表输出!
j = 0
i = 1
ClassSumRS1.MoveFirst
strReport = "考评类目" & Space(30) & "考评项目" & Space(29) & "标准分" & Space(2) & "实得分" & Space(2) & "备 注" & vbCrLf & ShortLine(100) & vbCrLf
Do While (Not ItemRS1.EOF)
     'Debug.Print Mid(ItemRS1.Fields("kpClass"), 2), ItemRS1.Fields(1), ItemRS1.Fields(2), ItemRS1.Fields(3), ItemRS1.Fields(4)
    '格式化输出,有汉字项空格*2作全角字符用!
    strReport = strReport & Mid(ItemRS1.Fields("kpClass"), 2) & Space(40 - 2 * Len(ItemRS1.Fields("kpClass")))
    strReport = strReport & ItemRS1.Fields("kpItem") & Space(40 - 2 * Len(ItemRS1.Fields("kpItem")))
    strReport = strReport & ItemRS1.Fields("StdScore") & Space(8 - Len(ItemRS1.Fields("StdScore")))
    strReport = strReport & ItemRS1.Fields("ActualScore") & Space(8 - Len(ItemRS1.Fields("ActualScore")))
    strReport = strReport & ItemRS1.Fields("Remark") & vbCrLf & vbCrLf
     j = j + 1
     If (j = ClassSumRS1.Fields("ClassItemNum")) Then
         j = 0
         'Debug.Print "小计", "参与", ClassSumRS1.Fields("StdSum"), ClassSumRS1.Fields("ActSum"), "实际:"; VClassScore(i).ActScore
         strReport = strReport & "小计" & Space(73) & ClassSumRS1.Fields("StdSum") & Space(8 - Len(ClassSumRS1.Fields("StdSum"))) & VClassScore(i).ActScore & vbCrLf & ShortLine(100) & vbCrLf
         i = i + 1
         ClassSumRS1.MoveNext
     End If
     ItemRS1.MoveNext
Loop
strReport = strReport & "总计" & Space(73) & TotalSumRS.Fields("TotalSum") & Space(5) & UnitScore & vbCrLf & vbCrLf
'Debug.Print "not include"
strReport = strReport & "所有未参评项目如下:" & vbCrLf & ShortLine(100) & vbCrLf
Do While (Not ItemRS2.EOF)
    'Debug.Print Mid(ItemRS2.Fields("kpClass"), 2), ItemRS2.Fields(1), ItemRS2.Fields(2), ItemRS2.Fields(3), ItemRS2.Fields(4)
    strReport = strReport & Mid(ItemRS2.Fields("kpClass"), 2) & Space(40 - 2 * Len(ItemRS2.Fields("kpClass")))
    strReport = strReport & ItemRS2.Fields("kpItem") & Space(40 - 2 * Len(ItemRS2.Fields("kpItem")))
    strReport = strReport & ItemRS2.Fields("StdScore") & Space(8 - Len(ItemRS2.Fields("StdScore"))) & vbCrLf & vbCrLf
    ItemRS2.MoveNext
Loop

strReport = strReport & "报表生成时间  " & Date & " " & Time
'Debug.Print strReport
If EnterpriseRS.Fields("Name") = EnterpriseName Then
    EnterpriseRS.Edit
    EnterpriseRS.Fields(TableName & "Score") = UnitScore
    EnterpriseRS.Fields(TableName & "Rep") = strReport
    EnterpriseRS.Update
Else
    MsgBox "system errorr!"
End If
frmReportView.txtRepContent = strReport
frmReportView.Show
ItemRS1.Close
Set ItemRS1 = Nothing
ItemRS2.Close
Set ItemRS2 = Nothing
ClassSumRS1.Close
Set ClassSumRS1 = Nothing
ClassSumRS2.Close
Set ClassSumRS2 = Nothing
TotalSumRS.Close
Set TotalSumRS = Nothing
ErrEmptyRS.Close
Set ErrEmptyRS = Nothing
TempQdf.Close
Set TempQdf = Nothing
End Sub

Private Sub cmdUpdate_Click()
    RS.Edit
    If Check1.Value = 1 Then '不参评
        RS.Fields("NotInclude") = True
        RS.Fields("ActualScore") = Null
        'RS.Fields("Remark") = "不参评"
        RS.Update
        Exit Sub
    Else
        RS.Fields("NotInclude") = False
    End If
    If IsNumeric(txtActualScore) Then 'And
        If CInt(txtActualScore) <= RS.Fields("StdScore") And CInt(txtActualScore) >= 0 Then
            RS.Fields("ActualScore") = CInt(txtActualScore)
        Else
            MsgBox "输入数据超出范围!"
        End If
    Else
        MsgBox "输入数据不是数字!"
    End If
    If txtRemark <> "" Then
        RS.Fields("Remark") = txtRemark
    Else
        RS.Fields("Remark") = "无"
    End If
    RS.Update
End Sub
Private Sub Form_Load()
Me.Move frmMain.ScaleWidth / 2 - Me.Width / 2, 0
bFrmShow = True 'Set Active Flag
Set RS = sysDB.OpenRecordset("Select * From " & TableName)
 If RS.BOF = True Then
    MsgBox "无相关记录!"
    Exit Sub
    Unload Me
 End If
 RS.MoveFirst
 txtClass = Mid(RS.Fields("kpClass"), 2)
 txtItem = RS.Fields("kpItem")
 txtContent = RS.Fields("kpContent")
 txtStdScore = RS.Fields("StdScore")
 txtMethod = RS.Fields("kpMethod")
 If RS.Fields("NotInclude") Then
    Check1.Value = 1
 Else
    Check1.Value = 0
 End If
 If IsNull(RS.Fields("ActualScore")) Then
   txtActualScore = ""
 Else
   txtActualScore = RS.Fields("ActualScore")
 End If
 If IsNull(RS.Fields("Remark")) Then
    txtRemark = ""
 Else
    txtRemark = RS.Fields("Remark")
 End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    RS.Close
    Set RS = Nothing
    bFrmShow = False 'Reset Flag
End Sub