frmsalaryfomularset.frm

金算盘软件代码

        End If
        If mlngTaxFieldID > 0 Then      '代扣税额
            strSql = "SELECT SalaryField.lngSalaryListID, SalaryField.lngViewFieldID, " & _
                     " SalaryField.lngSalaryFieldNO FROM SalaryField " & _
                     " WHERE SalaryField.lngSalaryListID= " & mlngSalaryID & _
                     " AND SalaryField.lngViewFieldID = 3521 "
            Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If recX.EOF Then
                strZ = "SELECT Max(SalaryField.lngSalaryFieldNo ) As maxNo " & _
                       " FROM SalaryField Where SalaryField.lngSalaryListID= " & mlngSalaryID
                 Set recZ = gclsBase.BaseDB.OpenResultset(strZ, rdOpenStatic)
                 If Not recZ.EOF Then
                    intMaxNO = recZ!MaxNo + 1
                Else
                    intMaxNO = 1
                End If
                recZ.Close
                Set recZ = Nothing
                strSql = "INSERT INTO SalaryField ( lngSalaryListID, lngViewFieldID, " & _
                         " lngSalaryFieldNO) Values ( " & mlngSalaryID & " ,3521, " & intMaxNO & ") "
                gclsBase.BaseDB.Execute strSql
            End If
        Else
            strSql = "DELETE FROM SalaryField WHERE SalaryField.lngViewFieldID = 3521 And " & _
                 "SalaryField.lngSalaryListID= " & mlngSalaryID
            gclsBase.BaseDB.Execute strSql
        End If
        If mlngDeductPutFieldID > 0 Then   '上次扣零
            strSql = "SELECT SalaryField.lngSalaryListID, SalaryField.lngViewFieldID, " & _
                     " SalaryField.lngSalaryFieldNO FROM SalaryField " & _
                     " WHERE SalaryField.lngSalaryListID= " & mlngSalaryID & _
                     " AND SalaryField.lngViewFieldID = 7699 "
            Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If recX.EOF Then
                strZ = "SELECT Max(SalaryField.lngSalaryFieldNo ) As maxNo " & _
                       " FROM SalaryField Where SalaryField.lngSalaryListID= " & mlngSalaryID
                 Set recZ = gclsBase.BaseDB.OpenResultset(strZ, rdOpenStatic)
                 If Not recZ.EOF Then
                    intMaxNO = recZ!MaxNo + 1
                Else
                    intMaxNO = 1
                End If
                recZ.Close
                Set recZ = Nothing
                strSql = "INSERT INTO SalaryField ( lngSalaryListID, lngViewFieldID, " & _
                         " lngSalaryFieldNO) Values ( " & mlngSalaryID & " ,7699, " & intMaxNO & ") "
                gclsBase.BaseDB.Execute strSql
            End If
        Else
            strSql = "DELETE FROM SalaryField WHERE SalaryField.lngViewFieldID = 7699  And " & _
                 "SalaryField.lngSalaryListID= " & mlngSalaryID
            gclsBase.BaseDB.Execute strSql
        End If
        gclsBase.BaseWorkSpace.CommitTrans
    End With
    '计算工资表
    frmSalaryEdit.Calc = True
    Call WriteSalaryList
    Unload Me
    Exit Sub
Errors:
    ShowMsg Me.hWnd, "公式表被其他用户打开，现在不允许修改。", vbInformation, Me.Caption
    On Error Resume Next
    gclsBase.BaseWorkSpace.RollBacktrans
End Sub

Private Sub cmdChangList_Click(index As Integer)
    mblnChangList = True
    If index = 0 Then
        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
        Call frmSalaryList.ChangList(False, Me.msgSalaryFormula(0), 9)
    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
        Call frmSalaryList.ChangList(True, Me.msgSalaryFormula(0), 9)
    End If
    mblnChangList = False
End Sub
Private Sub cmdOperator_Click(index As Integer)
    Dim intThisSelStart As Integer
    
    On Error Resume Next
    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
    Select Case msgSalaryFormula(0).col
    Case 1
        If index = 0 Or index = 1 Or index = 2 Or index = 3 Or index = 7 Or index = 11 Then
            intThisSelStart = txtSalaryFormula(0).SelStart
            txtSalaryFormula(0).Text = frmSalaryList.select_text(txtSalaryFormula(0).SelText, txtSalaryFormula(0).SelStart, _
            txtSalaryFormula(0).SelLength, txtSalaryFormula(0).Text, cmdOperator(index).Caption)
            txtSalaryFormula(0).SetFocus
            txtSalaryFormula(0).SelStart = intThisSelStart + Len(Trim(cmdOperator(index).Caption)) + 2
        Else
            txtSalaryFormula(0).SetFocus
        End If
    Case 2
        intThisSelStart = txtSalaryFormula(1).SelStart
        txtSalaryFormula(1).Text = frmSalaryList.select_text(txtSalaryFormula(1).SelText, txtSalaryFormula(1).SelStart, _
        txtSalaryFormula(1).SelLength, txtSalaryFormula(1).Text, cmdOperator(index).Caption)
        txtSalaryFormula(1).SetFocus
        txtSalaryFormula(1).SelStart = intThisSelStart + Len(Trim(cmdOperator(index).Caption)) + 2
    End Select
End Sub

Private Sub cmdOperator_GotFocus(index 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
        Select Case msgSalaryFormula(0).col
        Case 1
            If .TextMatrix(.Row, 9) <> "1" Then
                txtSalaryFormula(0).Visible = True
            End If
        Case 2
            If .TextMatrix(.Row, 4) <> "CalcZero" And .TextMatrix(.Row, 4) <> "CalcTax" _
                And .TextMatrix(.Row, 4) <> "PutZero" Then
                txtSalaryFormula(1).Visible = True
            End If
        End Select
    End With
End Sub
Private Sub cmdSalaryFormula_Click(index As Integer)
    Dim i As Long
    Dim j As Long
    '调用RowColChange事件写Grid
    Call Write_Grid
    Select Case index
    Case 0  '公式增加
        With msgSalaryFormula(0)
            If Trim(.TextMatrix(1, 0)) = "" Then
                .Row = 1
                .col = 0
                Exit Sub
            End If
            txtSalaryFormula(0).Visible = False
            txtSalaryFormula(1).Visible = False
            txtSalaryFormula(0).Text = ""
            txtSalaryFormula(1).Text = ""
            '调用公式校验
            .Row = .Rows - 1
            Call Check_Fomula
            '通过校验
            If mblnFomulaOk Then
                .TextMatrix(.Rows - 1, 6) = 1   '公式确认
                .AddItem ("")
                txtSalaryFormula(0).Visible = False
                txtSalaryFormula(1).Visible = False
                txtSalaryFormula(0).Text = ""
                txtSalaryFormula(1).Text = ""
                .Row = .Rows - 1
                .col = 0
            Else
                Exit Sub
            End If
        End With
        '设置按钮
        Call InitCommand
        With msgSalaryFormula(0)
            If UCase(.TextMatrix(.Row, 4)) <> "CALCZERO" And UCase(.TextMatrix(.Row, 4)) <> "CALCTAX" _
                And UCase(.TextMatrix(.Row, 4)) <> "PUTZERO" Then
                cboFormula.Visible = True
                cboFormula.SetFocus
            End If
        End With
    Case 1  '公式删除
        Call Delete_Formula
    Case 2  '公式确认
        
        Call Check_Fomula
        If mblnFomulaOk Then
            ShowMsg Me.hWnd, "公式校验通过。", vbInformation, Me.Caption
        End If
          
    Case 3  '函数向导
        With msgSalaryFormula(0)
            If UCase(Trim(.TextMatrix(.Row, 4))) = "CALCTAX" Or UCase(Trim(.TextMatrix(.Row, 4))) = _
                "PUTZERO" Or UCase(Trim(.TextMatrix(.Row, 4))) = "CALCZERO" Then
                ShowMsg Me.hWnd, "不能将扣零、扣税和发放扣零函数修改为其他函数。", vbInformation, Me.Caption
                Exit Sub
            End If
        End With
        Call SalaryFunction
    End Select
End Sub

Private Sub cmdSalaryFormula_GotFocus(index As Integer)
    If index = 0 Then
        With msgSalaryFormula(0)
            If txtSalaryFormula(0).Visible Then
                .TextMatrix(.Row, 1) = txtSalaryFormula(0).Text
            End If
            If txtSalaryFormula(1).Visible Then
                .TextMatrix(.Row, 2) = txtSalaryFormula(1).Text
            End If
        End With
        txtSalaryFormula(0).Visible = False
        txtSalaryFormula(1).Visible = False
        mblnDelete = False
    End If
End Sub

Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
End Sub

Private Sub Form_Click()
    cboFormula.Visible = False
    txtSalaryFormula(0).Visible = False
    txtSalaryFormula(1).Visible = False
End Sub
Private Sub Form_Load()
    Dim recViewField As rdoResultset
    Dim recSalaryFormula As rdoResultset
    Dim strName As String
    Dim strSql As String
    Dim i As Long
    Dim j As Long
    
    Me.Left = (Screen.width - Me.width) / 2
    Me.top = (Screen.Height - Me.Height) / 2
    mlngSalaryID = frmSalaryList.SalaryID
    'mstrSql = "SELECT ViewField.lngViewFieldID, ViewField.strViewFieldDesc " _
        & "FROM ViewField INNER JOIN SalaryField ON ViewField.lngViewFieldID " _
        & "= SalaryField.lngViewFieldID WHERE SalaryField.lngSalaryListID=" _
        & mlngSalaryID & " AND ViewField.lngViewFieldID<> 18324 AND ViewField.lngViewFieldID<> 18660 " _
        & " AND ViewField.lngViewFieldID<> 3520 AND ViewField.lngViewFieldID<> 3521 " _
        & " AND ViewField.lngViewFieldID<> 7699  " _
        & " AND Ucase( ViewField.strFieldType)='DOUBLE'"
    mstrSql = "SELECT ViewField.lngViewFieldID, ViewField.strViewFieldDesc " _
        & " FROM ViewField,SalaryField WHERE ViewField.lngViewFieldID = SalaryField.lngViewFieldID " _
        & " AND SalaryField.lngSalaryListID=" & mlngSalaryID _
        & " AND ViewField.lngViewFieldID<> 18324 AND ViewField.lngViewFieldID<> 18660 " _
        & " AND ViewField.lngViewFieldID<> 3520 AND ViewField.lngViewFieldID<> 3521 " _
        & " AND ViewField.lngViewFieldID<> 7699  " _
        & " AND UPPER( ViewField.strFieldType)='DOUBLE'" _
        & " ORDER BY ViewField.lngViewFieldID "
    '初始化工资目录表参数
    strSql = "SELECT * FROM SalaryList WHERE SalaryList.lngSalaryListID=" & mlngSalaryID
    Set recViewField = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    mdblDeductLevel = recViewField!dblDeductLevel
    mlngDeductFieldID = recViewField!lngDeductFieldID
    'mblnIsTax = recViewField!blnIsTax
    mblnIsTax = IIf(recViewField!blnIsTax = 1, True, False)
    mlngTaxFieldID = recViewField!lngTaxFieldID
    mlngDeductPutFieldID = recViewField!lngDeductPutFieldID
    mblnIsInit = True
    If mdblDeductLevel > 0 Then
        chkEdit(0).Value = 1
    End If
    If mblnIsTax Then
        chkEdit(2).Value = 1
    End If
    If mlngDeductPutFieldID > 0 Then
        chkEdit(1).Value = 1
    End If
    mblnIsInit = False
    With msgSalaryFormula(0)
        .ColWidth(0) = 1175
        .ColWidth(1) = 2345
        .ColWidth(2) = .width - 1175 - 2345
        .ColWidth(4) = 0
        .ColWidth(5) = 0
        .ColWidth(6) = 0
        .ColWidth(7) = 0
        .ColWidth(8) = 0
        .ColWidth(9) = 0
    End With
    '查找本次扣零、代扣税额的标题
    strSql = "SELECT ViewField.strViewFieldDesc FROM ViewField WHERE  ViewField.lngViewFieldID=3520"
    Set recViewField = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    mstrNowZeroName = Trim(recViewField!strViewFieldDesc)
    strSql = "SELECT ViewField.strViewFieldDesc FROM ViewField WHERE  ViewField.lngViewFieldID=3521"
    Set recViewField = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    mstrNowTaxName = Trim(recViewField!strViewFieldDesc)
    strSql = "SELECT ViewField.strViewFieldDesc FROM ViewField WHERE  ViewField.lngViewFieldID=7699"
    Set recViewField = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    mstrLastZeroName = Trim(recViewField!strViewFieldDesc)
    mintSalaryViewID = frmSalaryList.SalaryViewID
    mblnWriteCbo = False
    mblnChangList = False
    Set recViewField = gclsBase.BaseDB.OpenResultset("SELECT * FROM ViewField WHERE lngViewID=" _
        & mintSalaryViewID & "ORDER BY ViewField.lngViewFieldID", rdOpenStatic)
    '初始化选择项目
    With msgSalaryFormula(1)
        .Rows = 1
        .Clear