frmsalarylistnewwizard.frm

金算盘软件代码

        '更新发放范围
        Call Salary.EditSalaryEmployee(frmSalaryListNewWizard.msgWizard4, mlngSalaryID)
        '更新工龄
        strSql = "UPDATE Salary Set Sa18660 =0 Where lngSalaryListID=" & mlngSalaryID
        gclsBase.BaseDB.Execute (strSql)
        If mstrAgeMethod <> "0" Then
            'strSql = "UPDATE SalaryData Set Sa18660 = IIF(ISNULL(" & mstrAgeFormula & _
                     "),0," & mstrAgeFormula & ") Where lngSalaryListID=" & mlngSalaryID & " AND " & mstrAgeWhere
            strSql = "UPDATE SalaryData Set Sa18660 = NVL(" & mstrAgeFormula & _
                     ",0 ) Where lngSalaryListID=" & mlngSalaryID & " AND " & mstrAgeWhere
            gclsBase.BaseDB.Execute strSql
        End If
        '计算
        ''''''''''''''''
        Call Salary.SalaryCalc(" lngSalaryListID=" & mlngSalaryID, mlngSalaryID, 0, IIf(mdblDeductLevel > 0, True, _
            False), mblnIsTax, mlngDeductFieldID, mlngTaxFieldID, mdblDeductLevel, _
             mlngDeductPutFieldID, blnIsrefesh) '计算
    End If
    '重新计算工资表历史数据
    Call Salary.CalcOldData(mlngSalaryID, False)
    With frmSalaryList.msgSalaryList
        For i = 0 To .Cols - 1
            If Trim(.TextMatrix(0, i)) = "工资表名称" Then
                .TextMatrix(.Row, i) = Trim(txtWizard(0).Text)
                Exit For
            End If
        Next i
        For i = 0 To .Cols - 1
            If Trim(.TextMatrix(0, i)) = "发放日期" Then
                .TextMatrix(.Row, i) = Format(Calendar1.Value, "yyyy-mm-dd")
                Exit For
            End If
        Next i
        For i = 0 To .Cols - 1
            If Trim(.TextMatrix(0, i)) = "操作员" Then
                .TextMatrix(.Row, i) = gclsBase.OperatorName
                Exit For
            End If
        Next i
        Select Case Trim(frmSalaryList.cboFind.Text)
        Case "工资表名称"
            frmSalaryList.txtFindValue.Text = Trim(txtWizard(0).Text)
        Case "发放日期"
            frmSalaryList.txtFindValue.Text = Format(Calendar1.Value, "yyyy-mm-dd")
        Case "操作员"
            frmSalaryList.txtFindValue.Text = gclsBase.OperatorName
        End Select
    End With
Exit Sub
Errors:
    'gclsBase.BaseWorkSpace.RollBack
    gclsBase.BaseWorkSpace.RollBacktrans
    ShowMsg Me.hwnd, "数据库被其他用户打开，不能生成工资表。", vbInformation
    Unload Me
End Sub
'工资公式校验
Private Sub Check_Fomula()
    Dim strFomular As String       '公式
    Dim strCond As String          '条件
    Dim strSql As String
    Dim recSalaryTry As rdoResultset  '测试公式Rec
    Dim blnIsError As Boolean
    Dim strDateFunTmp1 As String
    Dim strDateFunTmp2 As String
    
    With msgWizard(4)
        mblnFomulaOk = False
        'strSql = "SELECT strTableName,strFieldType,lngViewFieldID FROM ViewField WHERE ViewField.lngViewID" _
            & "=63 AND  TRIM(ViewField.strViewFieldDesc)='" & Trim(.TextMatrix(.Row, 0)) & "'"
        strSql = "SELECT strTableName,strFieldType,lngViewFieldID FROM ViewField WHERE ViewField.lngViewID" _
            & "=63 AND LTRIM(RTRIM(ViewField.strViewFieldDesc))='" & Trim(.TextMatrix(.Row, 0)) & "'"
        Set recSalaryTry = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If recSalaryTry.EOF Then
            STbWizard.Tab = 5
            ShowMsg Me.hwnd, "计算项目：" & Trim(.TextMatrix(.Row, 0)) & "不存在。", vbInformation, Me.Caption
            .col = 0
            If UCase(.TextMatrix(.Row, 4)) <> "CALCZERO" And UCase(.TextMatrix(.Row, 4)) <> "CALCTAX" _
                And UCase(.TextMatrix(.Row, 4)) <> "PUTZERO" Then
                cboFomular.Visible = True
                On Error Resume Next
                cboFomular.SetFocus
                On Error GoTo 0
            End If
            Exit Sub
        End If
        If UCase(Trim(recSalaryTry!strTableName)) = "SALARY" And UCase(Trim(recSalaryTry!strFieldType)) = "DOUBLE" Then
            .TextMatrix(.Row, 3) = recSalaryTry!lngViewFieldID
        Else
            STbWizard.Tab = 5
            ShowMsg Me.hwnd, "项目：" & Trim(.TextMatrix(.Row, 0)) & "为不可计算项目。", vbInformation, Me.Caption
            .col = 0
            If UCase(.TextMatrix(.Row, 4)) <> "CALCZERO" And UCase(.TextMatrix(.Row, 4)) <> "CALCTAX" _
                And UCase(.TextMatrix(.Row, 4)) <> "PUTZERO" Then
                cboFomular.Visible = True
                On Error Resume Next
                cboFomular.SetFocus
                On Error GoTo 0
            End If
            Exit Sub
        End If
        '存回Txt到Grid
        Select Case .col
        Case 0
        Case 1
            .col = 4
            .col = 1
        Case 2
            .col = 5
            .col = 2
        End Select
        '调用公式校验
        If Len(Trim(.TextMatrix(.Row, 1))) > 0 And Trim(.TextMatrix(.Row, 0)) <> "" Then
            '扣零、扣税计算判断,CalcZero,CalcTax
            strFomular = Trim(.TextMatrix(.Row, 1))
            If InStr(strFomular, "扣零计算") > 0 Then
                Call ZeroTaxFunc("扣零计算", strFomular)
                Exit Sub
            End If
            If InStr(strFomular, "扣税计算") > 0 Then
                Call ZeroTaxFunc("扣税计算", strFomular)
                Exit Sub
            End If
            '统计函数或发放扣零校验
            If .TextMatrix(.Row, 9) = "1" Then
                .TextMatrix(.Row, 6) = 1
                mblnFomulaOk = True
                Exit Sub
            End If
            '校验公式
            mblnCond = False
            mblnFomulaOk = True
            '校验公式
            If .TextMatrix(.Row, 9) <> "1" Then
                '判断不存在关系运算符
                If InStr(.TextMatrix(.Row, 1), "=") > 0 Or InStr(.TextMatrix(.Row, 1), ">") > 0 Or _
                    InStr(.TextMatrix(.Row, 1), "<") > 0 Or InStr(.TextMatrix(.Row, 1), "<>") > 0 _
                    Or InStr(.TextMatrix(.Row, 1), " 并且 ") > 0 Or InStr(.TextMatrix(.Row, 1), " 且 ") > 0 _
                    Or InStr(.TextMatrix(.Row, 1), " 或 ") > 0 Or _
                    InStr(.TextMatrix(.Row, 1), " 或者 ") > 0 Then
                    mblnFomulaOk = False
                    STbWizard.Tab = 5
                    ShowMsg Me.hwnd, "计算公式不能含有：'=','>','<','<>','并且','或者','或','且'。", _
                        vbInformation, Me.Caption
                End If
            Else
                mblnFomulaOk = True
            End If
            If mblnFomulaOk = True Then
                '校验公式
                If .TextMatrix(.Row, 9) <> "1" Then
                    '替换运算符
                    strFomular = Trim(.TextMatrix(.Row, 1))
                    '替换回车
                    strFomular = Salary.Change_Text(Chr(13), " ", strFomular)
                    strFomular = Salary.Change_Text(Chr(10), " ", strFomular)
                    '替换Ctrl+I
                    strFomular = Salary.Change_Text(Chr(9), " ", strFomular)
                    '替换除号
                    strFomular = Salary.Change_Text("÷", "/", strFomular)
                    '替换乘号
                    strFomular = Salary.Change_Text("×", "*", strFomular)
                    Analysis strFomular
                    '通过校验
                    If mblnFomulaOk Then
                        '取出公式
                        mclsDepoland.GetFomular strFomular
                    End If
                End If
                '校验条件
                If Len(Trim(.TextMatrix(.Row, 2))) > 0 Then
                    mblnCond = True
                    '替换运算符
                    strCond = .TextMatrix(.Row, 2)
                    '替换回车
                    strCond = Salary.Change_Text(Chr(13), " ", strCond)
                    strCond = Salary.Change_Text(Chr(10), " ", strCond)
                    '替换Ctrl+I
                    strCond = Salary.Change_Text(Chr(9), " ", strCond)
                    '替换除号
                    strCond = Salary.Change_Text("÷", "/", strCond)
                    '替换乘号
                    strCond = Salary.Change_Text("×", "*", strCond)
                    '替换等号
                    strCond = Salary.Change_Text("＝", "=", strCond)
                    '替换并且
                    strCond = Salary.Change_Text("并且", " 且 ", strCond)
                    '替换或者
                    strCond = Salary.Change_Text("或者", " 或 ", strCond)
                    Analysis strCond
                    '通过校验
                    If mblnFomulaOk Then
                        '取出公式条件
                        mclsDepoland.GetFomular strCond
                        '根据关键字IN删除等号，如：部门名称='生产部'而'生产部'为非末级部门时，先在
                        'mclsDepoland_OnAccidenceParse中将'生产部'替换为：IN('一车间','二车间')。(其中'一车间'
                        ','二车间'为'生产部'的下级明细部门)则公式变为：部门名称=IN('一车间','二车间')，
                        '多出一个等号。ChangIN的功能是将多出的等号删除。计算条件中包含"IN('"系统认为可能多出一个等号
                        '将紧靠前的"="删除
                        Call Salary.ChangeIN(strCond)
                        .TextMatrix(.Row, 6) = "1"     '公式确认
                    Else
                        .TextMatrix(.Row, 6) = ""
                    End If
                Else
                    If mblnFomulaOk Then
                        .TextMatrix(.Row, 6) = "1"     '公式确认
                    Else
                        .TextMatrix(.Row, 6) = ""     '公式确认
                    End If
                End If
                If .TextMatrix(.Row, 6) = "1" Then
                    '写回英文公式
                    '校验公式
                    If .TextMatrix(.Row, 9) <> "1" Then
                        strDateFunTmp1 = ""
                        strDateFunTmp2 = ""
                        strDateFunTmp1 = Salary.GetOraDateFunnctionCalc(strFomular, strDateFunTmp2)
                        strSql = "SELECT " & strDateFunTmp1 & " AS dblValue " & " FROM SalaryData"
                        If strDateFunTmp2 <> "" Then
                            strSql = strSql & " WHERE " & strDateFunTmp2
                        End If
                        'strSql = "SELECT " & strFomular & " AS dblValue " & " FROM SalaryData"
                    Else  '校验函数
                        strSql = "SELECT * FROM SalaryData"
                    End If
                    If Len(Trim(strCond)) > 0 Then
                        strDateFunTmp1 = ""
                        strDateFunTmp2 = ""
                        strDateFunTmp1 = Salary.GetOraDateFunnctionCalc(strCond, strDateFunTmp2)
                        If InStr(UCase(strSql), "WHERE") > 0 Then
                            strSql = strSql & " AND " & strDateFunTmp1
                        Else
                            strSql = strSql & " WHERE " & strDateFunTmp1
                        End If
                        If strDateFunTmp2 <> "" Then
                            strSql = strSql & " AND " & strDateFunTmp2
                        End If
                    End If
                    blnIsError = False
                    On Error GoTo Errors1
                    Set recSalaryTry = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                    If Not blnIsError Then
                        If .TextMatrix(.Row, 9) <> "1" Then
                            .TextMatrix(.Row, 4) = strFomular
                        End If
                        .TextMatrix(.Row, 5) = strCond
                    Else
                        mblnFomulaOk = False
                        STbWizard.Tab = 5
                        ShowMsg Me.hwnd, "工资公式有误。", vbInformation, Me.Caption
                    End If
                    recSalaryTry.Close
                    Set recSalaryTry = Nothing
                End If
            End If
        Else
            If Len(Trim(.TextMatrix(.Row, 0))) = 0 Then
                STbWizard.Tab = 5
                ShowMsg Me.hwnd, "计算项目不允许为空。", vbInformation, "工资发放"
                .col = 0
            Else
                STbWizard.Tab = 5
                ShowMsg Me.hwnd, "计算公式不允许为空。", vbInformation, "工资发放"
                .col = 1
                If .TextMatrix(.Row, 9) <> "1" Then
                    txtWizard(1).Visible = True
                    On Error Resume Next
                    txtWizard(1).SetFocus
                    On Error GoTo 0
                End If
            End If
            mblnFomulaOk = False
        End If
    End With
    Exit Sub
Errors1:
    blnIsError = True
    Resume Next
End Sub
'设置职员列表(新增:为职员表所有职员(职员未停用,部门未停用)
'            (修改:符合原工资表的所有职员(可包停用职员和停用部门)
Private Sub SetEmployee()
    Dim strSelect As String
    Dim strFrom As String
    Dim strWhere As String
    Dim strSql As String
    Dim recEmployee As rdoResultset
    mblnInitmsgWizard4 = True
    
    mclsGrid.ColOfs = 3
    mclsGrid.ListSet.ViewId = 72
    With msgWizard4
        .Redraw = False
        .FixedCols = 0
    End With
    With mclsGrid.ListSet
        If Not mblnIsAddSalary Then
            strSelect = "Select Employee.lngEmployeeID As ID,0 AS intSourceTable,' ' As 选择," & .SelectOfSql
        Else
            strSelect = "Select Employee.lngEmployeeID As ID,0 AS intSourceTable, '√' As 选择," & .SelectOfSql
        End If
        Filter.DelSelectedCond mclsGrid.ListSet.ListID, 1
        strFrom = .FromOfSql
        strWhere = .WhereOfSql
    End With
    strSql = strSelect & " " & strFrom & " WHERE " & strWhere
'    strSql = strSql & " AND Employee.lngEmployeeID NOT IN(SELECT " & _
'            " lngEmployeeID FROM Salary WHERE lngSalaryListID=" & mlngSalaryID & ")"
    strSql = strSql & " AND  NOT Exists(SELECT " & _
            " lngEmployeeID FROM Salary WHERE Employee.lngEmployeeID=Salary.lngEmployeeid " _
            & " And lngSalaryListID=" & mlngSalaryID & ")"
    strSql = strSql & " AND Employee.blnIsInActive=0 "
    'strSql = strSql & " UNION " & _
            " SELECT Employee.lngEmployeeID AS ID, '√' AS 选择, Employee.strEmployeeCode AS 职员编号," & _
            " Employee.strEmployeeName AS 职员姓名, EmployeeType.strEmployeeTypeName AS 职员类别," & _
            " Department.strDepartmentName AS 所属部门, Title.strTitleName AS 职务," & _
            " IIf(Employee.blnIsMale=True,'男','女') AS 性别, Education.strEducationName AS 文化程度 " & _
            " FROM (((Salary INNER JOIN ((Employee LEFT JOIN Title ON Employee.lngTitleID = Title.lngTitleID) " & _
            " LEFT JOIN Education ON Employee.lngEducationID = Education.lngEducationID) ON  " & _
            " Salary.lngEmployeeID = Employee.lngEmployeeID) " & _
            " LEFT JOIN Department ON Salary.lngDepartmentID = Department.lngDepartmentID)" & _
            " LEFT JOIN EmployeeType ON Salary.lngEmployeeTypeID = EmployeeType.lngEmployeeTypeID) " & _
            " LEFT JOIN PersonTaxType ON Salary.lngPersonTaxTypeID = PersonTaxType.lngPersonTaxTypeID " & _
            " WHERE (Salary.lngSalaryListID = " & mlngSalaryID & " ) AND ( " & _
            " Employee.lngEmployeeID IN (SELECT lngEmployeeID FROM Salary WHERE lngSalaryListID = " & mlngSalaryID & "))"
    strSql = strSql & " UNION " & _
            " SELECT Employee.lngEmployeeID AS ID, 1 AS intSourceTable,'√' AS 选择, Employee.strEmployeeCode AS 职员编号," & _
            " Employee.strEmployeeName AS 职员姓名, EmployeeType.strEmployeeTypeName AS 职员类别," & _
            " Department.strDepartmentName AS 所属部门, Title.strTitleName AS 职务," & _
            " DECODE(Employee.blnIsMale,1,'男','女') AS 性别, Education.strEducationName AS 文化程度 " & _
            " FROM Salary,Employe