salary.bas

金算盘软件代码

                    strDateFunTmp1 = ""
                    strDateFunTmp2 = ""
                    strDateFunTmp1 = GetOraDateFunnctionCalc(recFormula!strFunctionCond, strDateFunTmp2)
                    strSql = strSql & " AND (" & strDateFunTmp1 & ") "
                    If strDateFunTmp2 <> "" Then
                        strSql = strSql & " AND " & strDateFunTmp2
                    End If
                End If
                Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                If Not rec.EOF Then
                    dblValue = IIf(IsNull(rec!dblValue), 0, rec!dblValue)
                End If
                strSql = "UPDATE SalaryData SET Sa" & recFormula!lngViewFieldID & "=" _
                    & dblValue
                '统计函数计算整个工资表
                If Trim(recFormula!strSalaryCond) <> "" Then
                    strSql = strSql & " WHERE (" & recFormula!strSalaryCond & ") AND lngSalaryListID=" _
                        & lngSalaryListID
                Else
                    strSql = strSql & " WHERE lngSalaryListID=" & lngSalaryListID
                End If
                gclsBase.BaseDB.Execute strSql
                '刷新工资表
                blnRefresh = True
            End If
            '非特殊函数
            If recFormula!strFormulaType <> "1" Then
                If blnByRowCalc Then
                    '在按GRID行计算中当前公式是否有变动项目参与计算,有变动项目计算当前公式,否则不计算当前公式
                    blnIsAllCalc = False
                    If InStr(UCase(Trim(recFormula!strSalaryFormula)), "SA" & lngEditViewFieldID) > 0 Or recFormula!lngViewFieldID = lngEditViewFieldID _
                         Or (Trim(recFormula!strSalaryCond) <> "" And InStr(UCase(Trim(recFormula!strSalaryCond)), "SA" & lngEditViewFieldID) > 0) Then
                        blnIsAllCalc = True
                    Else
                        For j = 0 To UBound(strArrChangeItem)
                            If Trim(strArrChangeItem(j)) <> "" Then
                                If InStr(UCase(Trim(recFormula!strSalaryFormula)), UCase(Trim(strArrChangeItem(j)))) > 0 Then
                                    blnIsAllCalc = True
                                    Exit For
                                Else
                                    If Trim(recFormula!strSalaryCond) <> "" Then
                                        If InStr(UCase(Trim(recFormula!strSalaryCond)), UCase(Trim(strArrChangeItem(j)))) > 0 Then
                                            blnIsAllCalc = True
                                            Exit For
                                        End If
                                    End If
                                End If
                            End If
                        Next
                    End If
                Else
                    blnIsAllCalc = True
                End If
                If blnIsAllCalc Then
                    '保证工资字段的小数位数..
                    strZ = "SELECT ViewField.lngViewFieldID, ViewField.bytFieldDec FROM ViewField " & _
                           " WHERE ViewField.lngViewFieldID = " & recFormula!lngViewFieldID
                    Set recZ = gclsBase.BaseDB.OpenResultset(strZ, rdOpenStatic)
                    strFildDec = recZ!bytFieldDec
                    intFildDec = CInt(strFildDec)
                    '格式化串
                    If intFildDec > 0 Then
                        strFildFlag = "9999999999999999999999999999990." & String(intFildDec, "0")
                    Else
                        strFildFlag = "9999999999999999999999999999990"
                    End If
                    'strSql = "UPDATE SalaryData SET Sa" & recFormula!lngViewFieldID & "=" _
                        & "Format( IIF(ISNULL(" & recFormula!strSalaryFormula & "),0," & recFormula!strSalaryFormula & "),'" & strFildFlag & "')"
                    strDateFunTmp1 = ""
                    strDateFunTmp2 = ""
                    strDateFunTmp1 = GetOraDateFunnctionCalc(recFormula!strSalaryFormula, strDateFunTmp2)
                    strSql = "UPDATE SalaryData SET Sa" & recFormula!lngViewFieldID & "=" _
                        & "TO_CHAR( NVL(" & strDateFunTmp1 & ",0),'" & strFildFlag & "')" _
                        & " Where " & strWhere
                    If strDateFunTmp2 <> "" Then
                        strSql = strSql & " AND " & strDateFunTmp2
                    End If
                    If Trim(recFormula!strSalaryCond) <> "" Then
                        strDateFunTmp1 = ""
                        strDateFunTmp2 = ""
                        strDateFunTmp1 = GetOraDateFunnctionCalc(recFormula!strSalaryCond, strDateFunTmp2)
                        strSql = strSql & " AND (" & strDateFunTmp1 & ") "
                        If strDateFunTmp2 <> "" Then
                            strSql = strSql & " AND " & strDateFunTmp2
                        End If
                    End If
                    gclsBase.BaseDB.Execute strSql
                    ReDim Preserve strArrChangeItem(UBound(strArrChangeItem) + 1)
                    strArrChangeItem(UBound(strArrChangeItem)) = "SA" & recFormula!lngViewFieldID
                End If
            End If
            recFormula.MoveNext
        Next
        blnIsRowRefesh = blnRefresh
    'End If
    Exit Function
Errors1:
    If InStr(UCase(Err.Description), "ORA-01438") > 1 Then
        strSql = "SELECT ViewField.strViewFieldDesc FROM ViewField Where lngViewid =63 And lngViewFieldid=" & recFormula!lngViewFieldID
        Set recZ = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recZ.EOF Then
            ShowMsg frmMain.hWnd, "'" & recZ!strViewFieldDesc & "'字段数据溢出，建议将增加此字段长度或检查工资录入和计算数据是否正确。", vbInformation, "工资计算"
            SalaryCalc = True
        Else
            Resume Next
        End If
        recZ.Close
        Set recZ = Nothing
    Else
        Resume Next
    End If
End Function
'修改项目
Public Sub EditSalaryItem(objGrid1 As Object, objgrid2 As Object)
    Dim recSalaryField As rdoResultset
    Dim strZ As String
    Dim lngSalaryID As Long
    Dim strSql As String
    Dim strSalarySql As String
    Dim intMsg As Integer
    Dim i As Integer
    
    lngSalaryID = frmSalaryList.SalaryID
    '查找本次发放要删除的项目
    i = 1
    With objGrid1
        strZ = ""
        If Len(Trim(.TextMatrix(1, 0))) = 0 Then     '无内容跳出循环
            i = 2
        End If
        Do While i < .Rows
            strSql = "SELECT SalaryField.*,ViewField.strTableName,ViewField.strFieldType " _
                & " FROM SalaryField,ViewField WHERE SalaryField.lngViewFieldID = " _
                & " ViewField.lngViewFieldID AND SalaryField.lngSalaryListID=" & lngSalaryID _
                & " AND LTRIM(RTRIM(SalaryField.lngViewFieldID))=" & .TextMatrix(i, 4)
            Set recSalaryField = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurRowVer, 64)
            If Not recSalaryField.EOF Then
                '不提示
                If Val(.TextMatrix(i, 4)) = 7699 Or Val(.TextMatrix(i, 4)) = 3520 Or Val(.TextMatrix(i, 4)) = 3521 _
                Or Val(.TextMatrix(i, 4)) = 18324 Or Val(.TextMatrix(i, 4)) = 18660 Then
                    intMsg = 1
                Else
                    intMsg = ShowMsg(frmMain.hWnd, "取消项目:" & Trim(.TextMatrix(i, 0)), vbOKCancel + vbDefaultButton1 + vbQuestion, "工资发放")
                End If
                If intMsg = 1 Then
                    '清除工资表数据
                    If Trim(recSalaryField!strTableName) = "Salary" Then
                        If Trim(recSalaryField!strFieldType) = "Double" Then
                            Select Case Val(.TextMatrix(i, 4))
                            Case 3520
                                strSalarySql = "UPDATE Salary SET dblNowZero=0"
                            Case 3521
                                strSalarySql = "UPDATE Salary SET dblNowTax=0"
                            Case 7699
                                strSalarySql = "UPDATE Salary SET dblLastZero=0"
                            Case 18324
                                strSalarySql = ""
                            Case 18660
                                strSalarySql = ""
                            Case Else
                                strSalarySql = "UPDATE Salary SET Sa" & .TextMatrix(i, 4) & "=0"
                            End Select
                        Else
                            If Val(.TextMatrix(i, 4)) = 18324 Then
                                strSalarySql = ""
                            Else
                                strSalarySql = "UPDATE Salary SET Sa" & .TextMatrix(i, 4) & "=''"
                            End If
                        End If
                        If strSalarySql <> "" Then
                            strSalarySql = strSalarySql & " WHERE lngSalaryListID=" & lngSalaryID
                            gclsBase.BaseDB.Execute strSalarySql
                        End If
                    End If
                    If strZ = "" Then
                        strZ = "(" & .TextMatrix(i, 4)
                    Else
                        strZ = strZ & "," & .TextMatrix(i, 4)
                    End If
                End If
            End If
            recSalaryField.Close
            Set recSalaryField = Nothing
            i = i + 1
        Loop
    End With
    '本次发放的项目
    i = 1
    With objgrid2
        Do While i < .Rows
            'strSql = "SELECT SalaryField.*,ViewField.strTableName,ViewField.strFieldType " _
                & " FROM SalaryField,ViewField WHERE SalaryField.lngViewFieldID = " _
                & " ViewField.lngViewFieldID AND SalaryField.lngSalaryListID=" & lngSalaryID _
                & " AND LTRIM(RTRIM(SalaryField.lngViewFieldID))=" & .TextMatrix(i, 4)
            strSql = "SELECT SalaryField.* " _
                & " FROM SalaryField WHERE SalaryField.lngSalaryListID=" & lngSalaryID _
                & " AND LTRIM(RTRIM(SalaryField.lngViewFieldID))=" & .TextMatrix(i, 4)
            Set recSalaryField = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurRowVer, 64)
            If recSalaryField.EOF Then
                recSalaryField.AddNew
                recSalaryField!lngViewFieldID = .TextMatrix(i, 4)
                recSalaryField!lngSalaryFieldNO = i
                recSalaryField!lngSalaryListID = lngSalaryID
                recSalaryField.Update
            Else
                recSalaryField.MoveFirst
                recSalaryField.Edit
                recSalaryField!lngSalaryFieldNO = i
                recSalaryField.Update
            End If
            recSalaryField.Close
            Set recSalaryField = Nothing
            i = i + 1
        Loop
    End With
    '删除非本次项目
    If Len(strZ) > 0 Then
        strSql = "DELETE  FROM SalaryField WHERE lngViewFieldID IN " & strZ & ")" & " AND SalaryField.lngSalaryListID =" & lngSalaryID
        gclsBase.BaseDB.Execute strSql
    End If
End Sub

'修改发放范围
Public Sub EditSalaryEmployee(objGrid As Object, lngSalaryID)
    Dim i As Integer
    Dim strInWhere As String
    Dim strSql As String
    Dim strDelSql As String
    Dim strName As String
    Dim intMsg As Integer
    Dim intCount1 As Integer
    Dim intCount2 As Integer
    Dim intSum As Integer
    
    strInWhere = ""
    strDelSql = ""
    intCount1 = 0