salarypolit.frm

金算盘软件代码

Private mstrSalaryListArr() As String                          '已选工资表
Private mstrSalaryArrId() As String                            '已选工资表ID
Private mstrSalaryFomularId() As String                        '计算公式中出现的数据来源工资表ID
Private mstrYear As String                                     '会计年度
Private mstrMonth As String                                    '会计期间
Private mblnYearIsChange As Boolean                            '会计年度或会计期间是否发生改变
Private mblnMonthIsEnd As Boolean                              '当前会计期限间是否已经结帐

Private mblnFomularIsRight As Boolean                          '计算公式是否正确
Private mblnFomularIsValid As Boolean                          '计算公式是否通过DepolandClass类检测
Private mlngSalaryFormulaID As Long                            '工资计算公式ID
Private mstrSalaryFormula As String                            '工资计算公式
Private mstrOLdSalaryFormula As String                         '原有的工资计算公式
Private mstrSalaryFormulaDesc As String                        '工资计算公式说明
Private mstrSalaryFormulaName As String                        '工资计算公式名称
Private Const mstrFomularNoByte = "<>?:;[]{}~''""""!@#$%^&=\|" '计算公式不允许出现的字符
Private Const mstrNameNoByte = "?*''""""!|"                    '计算公式名称不允许出现的字符
Private mstrTableSql As String                                 '计算公式用到的表别名
Private mstrTableWHERE As String                               '计算公式用到的条件
Private mlngFirstTableID As Long                               '计算公式中第一张工资表ID
Private mintCurrentStep As Integer                             '当前步骤
Private mblnStepIsRight(4) As Boolean                          '当前页面是否通过合法检测
Private mblnStepIsFirst(4) As Boolean                          '当前页面是否是第一次加载
Private mblnStepChange As Boolean                              'SSTAB的页面转换是否通过合法检测的触发

Private mblnCondition() As Boolean                             '当前条件是否发生改变
Private mstrWhereCndt As String                                '当前数据范围的WHERE条件子句
Private mintFlagRow As Integer                                 '当前辅助核算项目所在行
Private mstrCreditCode As String                               '当前贷方科目编号
Private mlngCreditID(6) As Long                                '当前贷方科目辅助核算项目ID数组
                                                               '  (0单位,1部门,2员工,3工程,4统计,5项目,6贷方科目)
Private mlngDebitID() As Long                                  '当前借方科目辅助核算项目ID数组(第一维 职员类别种类
                                                               '  (0单位,1部门,2员工,3工程,4统计,5项目,6借方科目,7职员类别)
Private mstrDebitCode() As String                              '当前借方科目编号数组
Private mstrCreditName As String                               '当前贷方科目
Private mstrdebitType() As String                              '当前借方科目对应的职员类别数组
Private mstrdebitTypeID() As String                            '当前借方科目对应的职员类别ID数组
Private mstrDebitName() As String                              '当前借方科目数组

Private mlngVoucherTypeID As Long                              '凭证类型ID
Private mstrRemark As String                                   '凭证摘要
Private mlngRemarkID As Long                                   '凭证摘要ID
Private mlngTempletID As Long                                  '凭证模板ID
Private mdblCreditMoney As Double                              '贷方金额
Private mdblDebitMoney() As Double                             '借方金额
Private mblnFormisFirst As Boolean                             '第一页面的初始化是否为窗体加载时触发
Private mlngVoucherID As Long                                  '生成的凭证ID
Private mblnAccountIsChange(2) As Boolean                      '工资已设科目是否发生改变依据标志（0 工资表，1 数据条件，2 计算公式）
Private mblnIsSaveaAccount  As Boolean                         '是否保存公式和科目
Private mblnIsAccountSelect As Boolean                         '借方科目的选择是否进行判断
Private mdlnIsNoItem As Boolean
Private mblnltxtIsFirst As Boolean

Private Sub cmdDelete_Click()
    Dim strSql As String
    Dim recZ As rdoResultset
    Dim strName As String
    Dim lngSalaryFormulaID As Long
    Dim intCount As Integer
    Dim strTmp As String
    
    strName = Trim(cboTurn.Text)
    If strName = "" Then
        ShowMsg Me.hwnd, "请选择要删除的公式。", vbInformation, Me.Caption
        Exit Sub
    End If
    strSql = "SELECT SalaryFormula.* FROM SalaryFormula " & _
             " Where SalaryFormula.strFormulaName='" & strName & "'"
    Set recZ = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurRowVer, 64)
    If recZ.EOF Then
        ShowMsg Me.hwnd, "没有可删除的公式。", vbInformation, Me.Caption
        Exit Sub
    Else
        lngSalaryFormulaID = recZ!lngSalaryFormulaID
        On Error GoTo ErrHandle
        gclsBase.BaseWorkSpace.BeginTrans
        strSql = "DELETE  FROM salaryAccount Where salaryAccount.lngsalaryformulaid =" & lngSalaryFormulaID
        gclsBase.ExecSQL (strSql)
        recZ.Delete
        gclsBase.BaseWorkSpace.CommitTrans
    End If
    cboTurn.Clear
    txtTurn.Text = ""
    'strSql = "Select SalaryFormula.strFormulaName  FROM SalaryFormula ,salaryAccount  " & _
             " WHERE SalaryFormula.lngsalaryformulaid=salaryAccount.lngsalaryformulaid " & _
             " And trim(SalaryFormula.strFormulaName) <> ''"
    strSql = "Select DISTINCT SalaryFormula.strFormulaName  FROM SalaryFormula ,salaryAccount  " & _
             " WHERE SalaryFormula.lngsalaryformulaid=salaryAccount.lngsalaryformulaid " & _
             " And LTRIM(RTRIM(SalaryFormula.strFormulaName)) IS NOT NULL "
    Set recZ = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recZ.EOF Then
        cmdDelete.Enabled = True
        recZ.MoveLast
        recZ.MoveFirst
        For intCount = 0 To recZ.RowCount - 1
            If Trim(recZ!strFormulaName) <> "" Then
                strTmp = recZ!strFormulaName
                CboAddSubject cboTurn, strTmp           '判断 COMBOBOX 增加的项目是否重复
            End If
            recZ.MoveNext
        Next
    Else
        cmdDelete.Enabled = False
    End If
    recZ.Close
    Set recZ = Nothing
    Exit Sub
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
    ShowMsg Me.hwnd, "其它用户正在使用数据库，不能删除公式。", vbInformation, Me.Caption
End Sub

Private Sub ltxtDebtor_KeyDown(KeyCode As Integer, Shift As Integer)
    With msgSalarySubject
        If KeyCode = 38 Then   '上方向键
            If .Row > 1 Then
                .Row = .Row - 1
                mintFlagRow = .Row
                ltxtDebtor.Visible = False
                On Error Resume Next
                msgSalarySubject.SetFocus
            End If
        ElseIf KeyCode = 40 Then  '下方向键
            If .Row < .Rows - 1 Then
                .Row = .Row + 1
                mintFlagRow = .Row
                ltxtDebtor.Visible = False
                On Error Resume Next
                msgSalarySubject.SetFocus
            End If
        ElseIf KeyCode = 37 Then      '左方向键
            If .col > 2 And ltxtDebtor.SelStart = 0 Then
                .col = .col - 1
                ltxtDebtor.Visible = False
                On Error Resume Next
                msgSalarySubject.SetFocus
            End If
        ElseIf KeyCode = 39 Then      '右方向键
            If .col < 4 And ltxtDebtor.SelStart = Len(ltxtDebtor.Text) Then
                .col = .col + 1
                ltxtDebtor.Visible = False
                On Error Resume Next
                msgSalarySubject.SetFocus
            End If
        ElseIf KeyCode = 13 Then  '回车键
            If .Row < .Rows - 1 Then
                .Row = .Row + 1
                mintFlagRow = .Row
                ltxtDebtor.Visible = False
                On Error Resume Next
                msgSalarySubject.SetFocus
            End If
        Else
        End If
    End With
End Sub

Private Sub ltxtDebtor_LostFocus()
    '借方科目(ltxtDebtor)的选择不为功能项
    If ltxtDebtor.ReferRow <> 0 And ltxtDebtor.ReferRow <> 1 And ltxtDebtor.ReferRow <> 2 Then
        With ltxtDebtor
            If .ReferRow > 0 Then
                If .TextMatrix(.ReferRow, 3) = False Then
                    ShowMsg SSTab1.hwnd, "你选择的科目不是末级科目，请重新选择。", vbInformation, Me.Caption
                    .Text = ""
                    .PopRefer
                    Exit Sub
                End If
            End If
        End With
    End If
End Sub

Private Sub ltxtResume_AddNew()
    Dim lngTmpID As Long
    
    ltxtResume.Text = ""
    '调用新增新增凭证摘要卡片
    lngTmpID = Card.AddCard(msgRemark)
    InitLtxtResume                      '初始化凭证摘要(LtxtResume)数据
    ltxtResume.SeekId (lngTmpID)
End Sub

Private Sub ltxtResume_Choose()
      '凭证摘要(LtxtResume)的选择不为功能项
    If ltxtResume.ReferRow <> 0 And ltxtResume.ReferRow <> 1 And ltxtResume.ReferRow <> 2 Then
        With ltxtResume
            If Not IsNull(.TextMatrix(.ReferRow, 1)) Then
                If Trim(.TextMatrix(.ReferRow, 1)) <> "" Then
                    mlngRemarkID = .TextMatrix(.ReferRow, 1)
                    mstrRemark = .TextMatrix(.ReferRow, 3)
                End If
            End If
        End With
    End If
End Sub

'初始化凭证摘要(LtxtResume)数据
Private Sub InitLtxtResume()
    Dim strSql As String
    Dim recRecordset As rdoResultset
    
    strSql = "SELECT Remark.lngRemarkID, Remark.strRemarkCode, Remark.strRemarkName FROM Remark " & _
             " ORDER BY Remark.strRemarkCode "
    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    ltxtResume.ClearRefer
    ltxtResume.CodeSort = True
    ltxtResume.SeekCol = "1,2,3"
    Set ltxtResume.Recordset = recRecordset
    'Set ltxtResume.Resultset = recRecordset
    ltxtResume.AddRefer "<新增>"
    ltxtResume.AddRefer "<修改>"
    ltxtResume.AddRefer "<删除>"
    recRecordset.Close
    Set recRecordset = Nothing
End Sub
Private Sub ltxtResume_Delete()
    ltxtResume.Text = ""
    If mlngRemarkID > 0 Then
        '调用删除凭证摘要卡片
        Card.DelCard msgRemark, mlngRemarkID
        InitLtxtResume                  '初始化凭证摘要(LtxtResume)数据
    Else
        ShowMsg SSTab1.hwnd, "请选择要删除的凭证摘要后再进行删除。", vbInformation, Me.Caption
    End If
End Sub

Private Sub ltxtResume_Edit()
    If mlngRemarkID > 0 Then
        '调用修改凭证摘要卡片
        Card.EditCard msgRemark, mlngRemarkID
        InitLtxtResume                  '初始化凭证摘要(LtxtResume)数据
    Else
        ShowMsg SSTab1.hwnd, "请选择要修改的凭证摘要后再进行修改。", vbInformation, Me.Caption
    End If
End Sub

Private Sub ltxtResume_ItemNotExist()
'    Dim lngTmpID As Long
'    Dim intTmp As Integer
    
'    intTmp = frmMsgAdd.MsgAddShow("新增凭证摘要", "没有凭证摘要：'" & ltxtResume.Text & "'。")
'    If intTmp = vbOK Then
'        '调用新增新增凭证摘要卡片
'        lngTmpID = Card.AddCard(msgRemark, ltxtResume.Text)
'        InitLtxtResume               '初始化凭证摘要(LtxtResume)数据
'        ltxtResume.SeekId (lngTmpID)
'    Else
'        ltxtResume.Text = ""
'    End If
End Sub

'初始化凭证模板(LtxtTemplet)数据
Private Sub InitLtxtTemplet()
    Dim strSql As String
    Dim recRecordset As rdoResultset
    'strSql = "SELECT Template.lngTemplateID, Template.strTemplateName " & _
             " FROM Receipt INNER JOIN (Template INNER JOIN ReceiptType ON  " & _
             " Template.lngReceiptTypeID = ReceiptType.lngReceiptTypeID) ON  " & _
             " Receipt.lngReceiptID = ReceiptType.lngReceiptID " & _
             " Where ReceiptType.lngReceiptTypeID = 41 And Template.blnIsInActive = False " & _
             " And (Template.bytVersion MOD 2*" & gVersionType & ")>(" & gVersionType & "-1) " & _
             " order by Template.lngTemplateID "
    strSql = "SELECT Template.lngTemplateID, Template.strTemplateName " & _
             " FROM Receipt,Template,ReceiptType " & _
             " Where Template.lngReceiptTypeID = ReceiptType.lngReceiptTypeID " & _
             " AND Receipt.lngReceiptID = ReceiptType.lngReceiptID " & _
             " AND ReceiptType.lngReceiptTypeID = 41 And Template.blnIsInActive = 0 " & _
             " And MOD(Template.bytVersion, 2*" & gVersionType & ")>(" & gVersionType & "-1) " & _
             " ORDER BY Template.lngTemplateID "
    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    ltxtTemplet.ClearRefer
    ltxtTemplet.SeekCol = "1,2,3"
    ltxtTemplet.CodeSort = True
    ltxtTemplet.SQL = strSql
    Set ltxtTemplet.Recordset = recRecordset
    'Set ltxtTemplet.Resultset = recRecordset
    ltxtTemplet.AddRefer "<新增>"
    ltxtTemplet.AddRefer "<修改>"
    ltxtTemplet.AddRefer "<删除>"
    recRecordset.Close
    Set recRecordset = Nothing
End Sub

Private Sub ltxtSubject_LostFocus()
    On Error Resume Next
    msgSalarySubject.SetFocus
    If msgSalarySubject.Rows > 1 Then msgSalarySubject.Row = 1
End Sub

Private Sub ltxtTemplet_AddNew()
    Dim lngTmpID As Long
            
    ltxtTemplet.Text = ""
    '调用新增新增凭证模板卡片
    lngTmpID = FrmNewTemplate.AddCard(, vbModal, , 41)
    InitLtxtTemplet                      '初始化凭证模板(LtxtTemplet)数据
    ltxtTemplet.SeekId (lngTmpID)
End Sub

Private Sub ltxtTemplet_Choose()
    '凭证模板(LtxtTemplet)的选择不为功能项
    If ltxtTemplet.ReferRow <> 0 And ltxtTemplet.ReferRow <> 1 And ltxtTemplet.ReferRow <> 2 Then
        With ltxtTemplet
            If Not IsNull(.TextMatrix(.ReferRow, 1)) Then
                If Trim(.TextMatrix(.ReferRow, 1)) <> "" Then
                    mlngTempletID = .TextMatrix(.ReferRow, 1)
                End If
            End If
        End With
    End If
End Sub

Private Sub ltxtTemplet_Delete()
    ltxtTemplet.Text = ""
    If mlngTempletID > 0 Then
        '调用删除凭证模板卡片
        Card.DelCard msgTemplate, mlngTempletID
        InitLtxtTemplet                 '初始化凭证模板(LtxtTemplet)数据
    Else
        ShowMsg SSTab1.hwnd, "请选择要删除的凭证模板后再进行删除。", vbInformation, Me.Caption
    End If
End Sub

Private Sub ltxtTemplet_Edit()
    ltxtTemplet.Text = ""
    If mlngTempletID > 0 Then