frmsalaryfomularset.frm

金算盘软件代码

        .Cols = 5
        .ColWidth(0) = 3200
        .ColWidth(1) = 0
        .ColWidth(2) = 0
        .ColWidth(3) = 0
        .ColWidth(4) = 0
        .ColAlignment(0) = 0
        i = 0
        j = 0
        cboFormula.Clear
        Do While Not recViewField.EOF()
            If Trim(.TextMatrix(0, 0)) <> "" Then
                .AddItem ("")
            End If
            '不包含本次扣零和本次扣税以及上次扣零
            If UCase(Trim(recViewField!strFieldType)) = "DOUBLE" And _
                UCase(Trim(recViewField!strFieldName)) <> "SALARY.DBLLASTZERO" _
                And UCase(Trim(recViewField!strFieldName)) <> "SALARY.DBLNOWZERO" _
                And UCase(Trim(recViewField!strFieldName)) <> "SALARY.DBLNOWTAX" _
                And UCase(Trim(recViewField!strFieldName)) <> "SALARY.SA18660" Then
                If UCase(Trim(recViewField!strFieldName)) <> "SALARY.STRBSNKCODR" Then
                    strName = Trim(recViewField!strViewFieldDesc)
                    cboFormula.AddItem (strName)
                    j = j + 1
                End If
            End If
            .TextMatrix(i, 0) = recViewField!strViewFieldDesc
            .TextMatrix(i, 1) = recViewField!lngViewFieldID
            .TextMatrix(i, 2) = recViewField!strFieldType
            .TextMatrix(i, 3) = recViewField!strTableName
            .TextMatrix(i, 4) = recViewField!strFieldName
            recViewField.MoveNext
            i = i + 1
        Loop
        For i = 0 To .Rows - 1
            .RowHeight(i) = 215
        Next
    End With
    '初始化计算公式
    Call Write_Formula
    '画线
    Set mclsSubClass32 = New SubClass32.SubClass
    mclsSubClass32.hWnd = msgSalaryFormula(0).hWnd
    mclsSubClass32.Messages(WM_PAINT) = True
    Set cmdAddItem(0).Picture = Utility.GetFormResPicture(1001, 0)
    Set cmdAddItem(1).Picture = Utility.GetFormResPicture(1002, 0)
    Set cmdChangList(0).Picture = Utility.GetFormResPicture(1019, 0)
    Set cmdChangList(1).Picture = Utility.GetFormResPicture(1020, 0)
    Set Me.Icon = Utility.GetFormResPicture(139, vbResIcon)
    Call InitCommand
    mblnIsOK = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Utility.RemoveFormResPicture (1001)
    Utility.RemoveFormResPicture (1002)
    Utility.RemoveFormResPicture (1019)
    Utility.RemoveFormResPicture (1020)
    Utility.RecordSetRefresh (139)
    Set frmSalaryFomularSet = Nothing
End Sub
Private Sub cboFormula_GotFocus()
    txtSalaryFormula(0).Visible = False
    txtSalaryFormula(0).Visible = False
    msgSalaryFormula(0).col = 0
End Sub
Private Sub cboFormula_LostFocus()
    If mblnWriteCbo Then
        Exit Sub
        cboFormula.Visible = False
    End If
    mblnWriteCbo = False
End Sub
Private Sub lstSalaryFormula_Click()
    Dim intThisSelStart As Integer
    With msgSalaryFormula(0)
        If UCase(.TextMatrix(.Row, 4)) = "CALCZERO" Or UCase(.TextMatrix(.Row, 4)) _
            = "PUTZERO" Or UCase(.TextMatrix(.Row, 4)) = "CALCTAX" Then
            Exit Sub
        End If
    End With
    If msgSalaryFormula(0).col = 2 Then
        intThisSelStart = txtSalaryFormula(1).SelStart
        txtSalaryFormula(1).Text = frmSalaryList.select_text(txtSalaryFormula(1).SelText, txtSalaryFormula(1).SelStart, _
        txtSalaryFormula(1).SelLength, txtSalaryFormula(1).Text, lstSalaryFormula.Text)
        txtSalaryFormula(1).Visible = True
        txtSalaryFormula(1).SetFocus
        txtSalaryFormula(1).SelStart = intThisSelStart + Len(Trim(lstSalaryFormula.Text)) + 2
    End If
End Sub
'公式项目校验
Private Sub mclsDepoland_OnAccidenceParse(ByVal strToken As String, token As TokenClass, blnOK As Boolean)
    Dim i As Long
    Dim strMsg As String
    Dim strString As String
    Dim strSql As String
    Dim recRecordset As rdoResultset
    Dim strFormula As String
    
    strToken = Trim(strToken)
    i = 0
    With msgSalaryFormula(1)
        Do While i < .Rows
            '计算公式中含有字符型字段
            If UCase(Trim(strToken)) = UCase(Trim(.TextMatrix(i, 0))) Then
                '公式中加入日期型计算项目
                If mblnCond = False And UCase(.TextMatrix(i, 2)) <> "DOUBLE" And UCase(.TextMatrix(i, 2)) _
                    <> "DATE" Then
                    ShowMsg Me.hWnd, "计算公式不能包含文本型字段。", vbInformation, "工资发放"
                    mblnFomulaOk = blnOK
                    Exit Sub
                End If
                mstrFormulaItemname = strToken
                If strToken = "性别" Then
                    token.Value = "blnIsMale"
                Else
                    token.Value = Right(.TextMatrix(i, 4), Len(Trim(.TextMatrix(i, 4))) - Len(Trim(.TextMatrix(i, 3))) - 1)
                End If
                If UCase(.TextMatrix(i, 2)) = "DATE" Then
                    token.Value = token.Value
                End If
                blnOK = True
                Exit Do
            End If
           i = i + 1
        Loop
    End With
    If blnOK = False Then
        If Left(Trim(strToken), 1) = "'" And Right(Trim(strToken), 1) = "'" And mblnCond Then
            '查找项目值
            strSql = ""
            strFormula = strToken
            On Error GoTo Errors1
            Select Case mstrFormulaItemname
            Case "部门名称"
                '判断是否为非明细
                'strSql = "SELECT blnIsDetail,strDepartmentCode From DepartMent WHERE TRIM(strDepartmentName)=" _
                    & strFormula
                strSql = "SELECT blnIsDetail,strDepartmentCode From DepartMent WHERE Upper(LTRIM(RTRIM(strDepartmentName)))=" _
                    & UCase(strFormula)
                Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                If recRecordset.EOF Then
                    ShowMsg Me.hWnd, "部门：" & strFormula & "不存在。", vbInformation, "工资发放"
                    blnOK = False
                    mblnFomulaOk = blnOK
                    Exit Sub
                End If
                'If Not recRecordset!blnIsDetail Then
                If recRecordset!blnIsDetail = 0 Then
                    'strSql = "SELECT strDepartmentName From DepartMent WHERE blnIsDetail=True AND InStr" _
                        & "(strDepartmentCode,'" & Trim(recRecordset!strDepartmentCode) & "-')=1"
                    strSql = "SELECT strDepartmentName From DepartMent WHERE blnIsDetail=1 AND InStr" _
                        & "(strDepartmentCode,'" & Trim(recRecordset!strDepartmentCode) & "-')=1"
                    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                    '查找下级明细
                    If Not recRecordset.EOF Then
                        recRecordset.MoveLast
                        recRecordset.MoveFirst
                        strFormula = " IN("
                        Do While Not recRecordset.EOF
                            strFormula = strFormula & "'" & recRecordset!strDepartmentName & "',"
                            recRecordset.MoveNext
                        Loop
                        strFormula = Left(strFormula, Len(strFormula) - 1)
                        strFormula = strFormula & ")"
                    End If
                End If
            Case "职员类别"
                'strSql = "SELECT blnIsDetail,strEmployeeTypeCode From EmployeeType WHERE TRIM(strEmployeeTypeName)=" _
                    & strFormula
                strSql = "SELECT blnIsDetail,strEmployeeTypeCode From EmployeeType " & _
                         " WHERE Upper(LTRIM(RTRIM(strEmployeeTypeName)))=" & UCase(strFormula)
                On Error GoTo Errors1
                Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                If recRecordset.EOF Then
                    ShowMsg Me.hWnd, "职员类别：" & strFormula & "不存在。", vbInformation, "工资发放"
                    Exit Sub
                End If
                'If Not recRecordset!blnIsDetail Then
                If recRecordset!blnIsDetail = 0 Then
                    'strSql = "SELECT strEmployeeTypeName From EmployeeType WHERE blnIsDetail=True AND InStr" _
                        & "(strEmployeeTypeCode,'" & Trim(recRecordset!strEmployeeTypeCode) & "-')=1"
                    strSql = "SELECT strEmployeeTypeName From EmployeeType WHERE blnIsDetail=1 AND InStr" _
                        & "(strEmployeeTypeCode,'" & Trim(recRecordset!strEmployeeTypeCode) & "-')=1"
                    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                    '查找下级明细
                    If Not recRecordset.EOF Then
                        recRecordset.MoveLast
                        recRecordset.MoveFirst
                        strFormula = " IN("
                        Do While Not recRecordset.EOF
                            strFormula = strFormula & "'" & recRecordset!strEmployeeTypeName & "',"
                            recRecordset.MoveNext
                        Loop
                        strFormula = Left(strFormula, Len(strFormula) - 1)
                        strFormula = strFormula & ")"
                    End If
                End If
            End Select
            If mstrFormulaItemname = "性别" Then
                token.Value = IIf(strFormula = "'男'", 1, 0)
            Else
                token.Value = strFormula
            End If
            blnOK = True
            mstrFormulaItemname = ""
        End If
    End If
    If blnOK = False Then
        If Len(Trim(strToken)) > 30 Then
            strString = Left(Trim(strToken), 24) & "......"
        Else
            strString = Trim(strToken)
        End If
        ShowMsg Me.hWnd, "不能识别：'" & strString & "'。", vbInformation, Me.Caption
    End If
    mblnFomulaOk = blnOK
    Exit Sub
Errors1:
    ShowMsg Me.hWnd, "不能识别：'" & strFormula & "'。", vbInformation, Me.Caption
    blnOK = False
    mblnFomulaOk = blnOK
End Sub
Private Sub mclsSubClass32_WndProc(Msg As Long, wParam As Long, lParam As Long, Result As Long)
    Select Case Msg
        Case WM_PAINT
            mclsSubClass32.CallWndProc Msg, wParam, lParam
            With msgSalaryFormula(0)
               Call DrawBLine(.hWnd, .ColWidth(0) - 20, 0, .ColWidth(0) - 20, _
                    3040, RGB(128, 128, 128))
               Call DrawBLine(.hWnd, .ColWidth(0) + .ColWidth(1) - 20, 0, .ColWidth(0) + _
                    .ColWidth(1) - 20, 3040, RGB(128, 128, 128))

            End With
    End Select
End Sub
Private Sub msgSalaryFormula_Click(index As Integer)
    Dim recItem As rdoResultset
    Dim strSql As String

    If cboFormula.Visible = True And index = 0 Then
        mblnWriteCbo = True
    End If
    If index = 1 Then
        With msgSalaryFormula(1)
            '职员信息和代发银行帐号
            If UCase(Trim(.TextMatrix(.Row, 3))) <> "SALARY" Or UCase(Trim(.TextMatrix(.Row, 4))) = "SALARY.STRBANKCODE" Then '参照表
                lstSalaryFormula.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
                                lstSalaryFormula.AddItem (recItem!Item)
                            End If
                        End If
                    Else
                        If Not IsNull(recItem!Item) Then
                            If Trim(recItem!Item) <> "" Then
                                lstSalaryFormula.AddItem ("'" & recItem!Item & "'")
                            End If
                        End If
                    End If
                    recItem.MoveNext
                Loop
                recItem.Close
                Set recItem = Nothing
                If lstSalaryFormula.ListCount = 1 And Trim(lstSalaryFormula.list(0)) = "'男'" Then
                    lstSalaryFormula.AddItem ("'女'")
                End If
                If lstSalaryFormula.ListCount = 1 And Trim(lstSalaryFormula.list(0)) = "'女'" Then
                    lstSalaryFormula.AddItem ("'男'")
                End If
            Else
                lstSalaryFormula.Clear
            End If
        End With
    Else
        With msgSalaryFormula(0)
            Select Case .col
            Case 1
                '将txt框写回工资列表
                If txtSalaryFormula(0).Visible Then
                    .TextMatrix(.Row, 1) = txtSalaryFormula(0).Text
                End If
            Case 2
                '将txt框写回工资列表
                If txtSalaryFormula(1).Visible Then
                    .TextMatrix(.Row, 2) = txtSalaryFormula(1).Text
                End If
            End Select
        End With
    End If
End Sub
Private Sub msgSalaryFormula_DblClick(index As Integer)
    Dim intThisSelStart As Integer
    '计算项目
    If index = 1 Then
        Select Case msgSalaryFormula(0).col
        Case 0  '选择项目
            '特殊函数
            With msgSalaryFormula(0)
                If UCase(.TextMatrix(.Row, 4)) = "CALCZERO" Or UCase(.TextMatrix(.Row, 4)) _
                    = "PUTZERO" Or UCase(.TextMatrix(.Row, 4)) = "CALCTAX" Then
                    Exit Sub
                End If
            End With
            With msgSalaryFormula(1)
                If UCase(.TextMatrix(.Row, 2)) = "DOUBLE" And UCase(.TextMatrix(.Row, 4)) <> "SALARY.SA18660" Then
                    msgSalaryFormula(0).TextMatrix(msgSalaryFormula(0).Row, 0) = .TextMatrix(.Row, 0)
                    msgSalaryFormula(0).TextMatrix(msgSalaryFormula(0).Row, 3) = .TextMatrix(.Row, 1)
                    cboFormula.Text = .TextMatrix(.Row, 0)
                    Call cboFormula_Click
                End If
            End With
        Case 1  '选择公式