frmsalaryfunction.frm

金算盘软件代码

                lstList.Clear
                strSql = "SELECT " & .TextMatrix(.Row, 4) & " AS Item FROM " & .TextMatrix(.Row, 3) & _
                         " GROUP BY " & .TextMatrix(.Row, 4)
                Set recItem = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                Do While Not recItem.EOF()
                    If UCase(.TextMatrix(.Row, 2)) = "DOUBLE" Then
                        If Not IsNull(recItem!Item) Then
                            If Trim(str(recItem!Item)) <> "" Then
                                lstList.AddItem (recItem!Item)
                            End If
                        End If
                    Else
                        If Not IsNull(recItem!Item) Then
                            If Trim(recItem!Item) <> "" Then
                                lstList.AddItem ("'" & recItem!Item & "'")
                            End If
                        End If
                    End If
                    recItem.MoveNext
                Loop
                recItem.Close
                Set recItem = Nothing
            Else
                lstList.Clear
            End If
    End With
    
End Sub
'校验公式
Private Function CheckFormula() As Boolean
    Dim blnIsError As Boolean
    Dim strFormula As String
    Dim recSalaryTry As rdoResultset
    Dim strDateFunTmp1 As String
    Dim strDateFunTmp2 As String
    
    '校验工资表
    With litEdit(0)
        If .ID < 1 Then
            If .Text <> "上次发放工资表" And .Text <> "本次发放工资表" Then
                CheckFormula = False
                .SetFocus
                ShowMsg Me.hwnd, "工资表录入有误。", vbInformation, Me.Caption
                Exit Function
            End If
        End If
    End With
    '校验工资项目
    With litEdit(1)
        If .ID < 1 And cobEdit.ListIndex <> 4 Then
            CheckFormula = False
            .SetFocus
            ShowMsg Me.hwnd, "计算项目录入有误。", vbInformation, Me.Caption
            Exit Function
        End If
    End With
    If cobEdit.Text = "" Then
        cobEdit.SetFocus
        ShowMsg Me.hwnd, "函数类型不能为空。", vbInformation, Me.Caption
        Exit Function
    End If
    '替换运算符
    strFormula = txtEdit.Text
    '替换回车
    strFormula = Salary.Change_Text(Chr(13), " ", strFormula)
    strFormula = Salary.Change_Text(Chr(10), " ", strFormula)
    '替换Ctrl+I
    strFormula = Salary.Change_Text(Chr(9), " ", strFormula)
    '替换除号
    strFormula = Salary.Change_Text("÷", "/", strFormula)
    '替换乘号
    strFormula = Salary.Change_Text("×", "*", strFormula)
    '替换等号
    strFormula = Salary.Change_Text("＝", "=", strFormula)
    '校验
    If Trim(txtEdit.Text) <> "" Then
        Analysis strFormula
    Else
        mblnFormulaOk = True
    End If
    '通过校验
    If mblnFormulaOk Then
        If Trim(txtEdit.Text) <> "" Then
            mclsDepoland.GetFomular strFormula
            '删除等号
            Call Salary.ChangeIN(strFormula)
            '试运行
            If Len(Trim(strFormula)) > 0 Then
                strDateFunTmp1 = ""
                strDateFunTmp2 = ""
                strDateFunTmp1 = Salary.GetOraDateFunnctionCalc(strFormula, strDateFunTmp2)
                strSql = "SELECT * FROM SalaryData WHERE " & strDateFunTmp1
                If strDateFunTmp2 <> "" Then
                    strSql = strSql & " AND " & strDateFunTmp2
                End If
                'strSql = "SELECT * FROM SalaryData WHERE " & strFormula
            End If
            On Error GoTo Errors
            blnIsError = False
            'Set recSalaryTry = gclsBase.BaseDB.OpenRecordset(Strsql, dbOpenSnapshot)
            Set recSalaryTry = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        Else
            blnIsError = False
        End If
        If Not blnIsError Then
            Select Case cobEdit.ListIndex
            Case 0    '"求合计"
                mstrFormula = "Sum(Sa" & litEdit(1).ID & ")"
                If Trim(txtEdit.Text) <> "" Then
                    mstrFormulaDesc = "求合计(" & litEdit(1).Text & "," & txtEdit.Text & ")"
                    mstrFormulaWHERE = strFormula
                Else
                    mstrFormulaDesc = "求合计(" & litEdit(1).Text & ")"
                    mstrFormulaWHERE = ""
                End If
            Case 1    '"求平均"
                mstrFormula = "Avg(Sa" & litEdit(1).ID & ")"
                If Trim(txtEdit.Text) <> "" Then
                    mstrFormulaDesc = "求平均(" & litEdit(1).Text & "," & txtEdit.Text & ")"
                    mstrFormulaWHERE = strFormula
                Else
                    mstrFormulaDesc = "求平均(" & litEdit(1).Text & ")"
                    mstrFormulaWHERE = ""
                End If
            Case 2    '"求最大"
                mstrFormula = "Max(Sa" & litEdit(1).ID & ")"
                If Trim(txtEdit.Text) <> "" Then
                    mstrFormulaDesc = "求最大(" & litEdit(1).Text & "," & txtEdit.Text & ")"
                    mstrFormulaWHERE = strFormula
                Else
                    mstrFormulaDesc = "求最大(" & litEdit(1).Text & ")"
                    mstrFormulaWHERE = ""
                End If
            Case 3    '"求最小"
                mstrFormula = "Min(Sa" & litEdit(1).ID & ")"
                If Trim(txtEdit.Text) <> "" Then
                    mstrFormulaDesc = "求最小(" & litEdit(1).Text & "," & txtEdit.Text & ")"
                    mstrFormulaWHERE = strFormula
                Else
                    mstrFormulaDesc = "求最小(" & litEdit(1).Text & ")"
                    mstrFormulaWHERE = ""
                End If
            Case 4    '"求人数"
                mstrFormula = "Count(lngEmployeeID)"
                If Trim(txtEdit.Text) <> "" Then
                    mstrFormulaDesc = "求人数(" & txtEdit.Text & ")"
                    mstrFormulaWHERE = strFormula
                Else
                    mstrFormulaDesc = "求人数()"
                    mstrFormulaWHERE = ""
                End If
            End Select
            CheckFormula = True
        Else
            mblnFomulaOk = False
            ShowMsg Me.hwnd, "计算条件有误。", vbInformation, Me.Caption
        End If
    End If
    Exit Function
Errors:
    blnIsError = True
    Resume Next
End Function
Private Function Analysis(ByVal strFormula As String) As Boolean
    Set mclsDepoland = New DepolandClass
    Analysis = mclsDepoland.VerifyFomular(strFormula)
End Function
'初始化计算项目
Private Sub InitSalaryItem()
    Dim strSql As String
    Dim rec As rdoResultset
    Dim i As Integer
    '初始化项目
    strSql = "SELECT strViewFieldDesc,lngViewFieldID,strFieldType," _
        & "strTableName,strFieldName FROM ViewField WHERE lngViewID=63"
    Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    With msgGrid
        .Rows = 1
        .Clear
        .Cols = 5
        .ColWidth(0) = .width
        .ColWidth(1) = 0
        .ColWidth(2) = 0
        .ColWidth(3) = 0
        .ColWidth(4) = 0
        .ColAlignment(0) = 0
        i = 0
        Do While Not rec.EOF
            If i = .Rows Then
                .Rows = .Rows + 1
            End If
            .TextMatrix(i, 0) = rec!strViewFieldDesc
            .TextMatrix(i, 1) = rec!lngViewFieldID
            .TextMatrix(i, 2) = rec!strFieldType
            .TextMatrix(i, 3) = rec!strTableName
            .TextMatrix(i, 4) = rec!strFieldName
            rec.MoveNext
            i = i + 1
        Loop
    End With
    '初始化计算项目
    strSql = "SELECT lngViewFieldID,strViewFieldDesc FROM ViewField " _
        & " WHERE lngViewID=63 AND strFieldName NOT IN('SALARY.DBLLASTZERO','SALARY.DBLNOWZERO'," _
        & " 'SALARY.DBLNOWTAX') AND UPPER(strTableName)='SALARY' AND UPPER(strFieldType) = 'DOUBLE'" _
        & " Order by strViewFieldDesc "
    litEdit(1).ClearRefer
    litEdit(1).SQL = strSql
    litEdit(1).SeekCol = "1,2"
    litEdit(1).CodeSort = True
    Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Set litEdit(1).Recordset = rec
End Sub
'修改函数
Public Function EditFunction(ByRef lngSalaryListID As Long, ByRef strFormula As String, ByRef strFormulaDesc As String, _
    ByRef strFormulaWhere As String) As Boolean
    '函数统计的工资表ID，函数统计的字段，函数名称，函数条件描写，函数条件
    '初始化工资表选择项目
    Dim i, j As Integer
    Call InitSalaryTable
    '初始化计算项目选择项
    Call InitSalaryItem
    '初始化工资表内容
    Select Case lngSalaryListID
    Case 0
        litEdit(0).Text = "本次发放工资表"
    Case -1
        litEdit(0).Text = "上次发放工资表"
    Case Else
        litEdit(0).SeekId lngSalaryListID
    End Select
    '初始化计算项目和条件(将计算函数分解为计算项目和条件)
    strFormulaDesc = Trim(strFormulaDesc)
    i = InStr(strFormulaDesc, ",")
    j = InStr(strFormulaDesc, "(")
    '初始化计算项目内容
    If InStr(strFormula, "Count") = 1 Then    '求人数的处理
        i = InStr(strFormulaDesc, "(")
        litEdit(1).Text = ""
        strFormulaDesc = Left(strFormulaDesc, Len(strFormulaDesc) - 1)
        i = Len(strFormulaDesc) - i
        If i > 0 Then
            strFormulaDesc = Right(strFormulaDesc, i)
        Else
            strFormulaDesc = ""
        End If
        txtEdit.Text = strFormulaDesc
        mstrFormulaWHERE = strFormulaWhere
        If InStr(strFormula, "Count") = 1 Then
            cobEdit.ListIndex = 4
        End If
    Else
        If i = 0 Then
            i = InStr(strFormulaDesc, ")")
        End If
        'litEdit(1).Text = Left(strFormulaDesc, i - 1)
        litEdit(1).Text = Right(Left(strFormulaDesc, i - 1), i - 1 - j)
        strFormulaDesc = Left(strFormulaDesc, Len(strFormulaDesc) - 1)
        i = Len(strFormulaDesc) - i
        If i > 0 Then
            strFormulaDesc = Right(strFormulaDesc, i)
        Else
            strFormulaDesc = ""
        End If
        txtEdit.Text = strFormulaDesc
        mstrFormulaWHERE = strFormulaWhere
        '初始化函数
        If InStr(strFormula, "Sum") = 1 Then
            cobEdit.ListIndex = 0
        End If
        If InStr(strFormula, "Avg") = 1 Then
            cobEdit.ListIndex = 1
        End If
        If InStr(strFormula, "Max") = 1 Then
            cobEdit.ListIndex = 2
        End If
        If InStr(strFormula, "Min") = 1 Then
            cobEdit.ListIndex = 3
        End If
    End If
    Me.Show vbModal
    EditFunction = mblnOk
    strFormula = mstrFormula
    strFormulaDesc = mstrFormulaDesc
    strFormulaWhere = mstrFormulaWHERE
    If litEdit(0).ID >= 0 Then
        '本次发放的工资表
        If litEdit(0).Text = "本次发放工资表" Then
            lngSalaryListID = 0
        ElseIf litEdit(0).Text = "上次发放工资表" Then
            lngSalaryListID = -1
        Else
            lngSalaryListID = litEdit(0).ID
        End If
    Else
        If litEdit(0).Text = "上次发放工资表" Then
            lngSalaryListID = -1
        ElseIf litEdit(0).Text = "本次发放工资表" Then
            lngSalaryListID = 0
        End If
    End If
    Unload Me
End Function
Private Sub txtEdit_KeyPress(KeyAscii As Integer)
    If KeyAscii = 124 Then
        SendKeys "{BACKSPACE}"
    End If
End Sub