frmdispart.frm

金算盘软件代码

                ValidAccount2 = False
                Msg = "科目不存在！"
            End If
        End If
        If ValidAccount2 Then
            strSql = "SELECT * FROM Account WHERE lngAccountID=" & ltxtAcc22.ID
            'Set recAccount = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
            Set recAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If Not recAccount.EOF Then
                'If Not recAccount!blnIsDetail Then
                If recAccount!blnIsDetail = 0 Then
                    ValidAccount2 = False
                    Msg = "结余分配科目必须是明细科目！"
                'ElseIf recAccount!blnIsCustomer Or recAccount!blnIsDepartment Or recAccount!blnIsEmployee Or _
                    recAccount!blnIsClass1 Or recAccount!blnIsClass2 Or _
                    recAccount!blnIsQuantity Or recAccount!blnIsMultCurrency Or recAccount!blnIsAllCurrency Then
                 ElseIf recAccount!blnIsCustomer = 1 Or recAccount!blnIsDepartment = 1 Or recAccount!blnIsEmployee = 1 Or _
                    recAccount!blnIsClass1 = 1 Or recAccount!blnIsClass2 = 1 Or _
                    recAccount!blnIsQuantity = 1 Or recAccount!blnIsMultCurrency = 1 Or recAccount!blnIsAllCurrency = 1 Then
                    ValidAccount2 = False
                    Msg = "结余分配科目不能有辅助核算,也不能进行外币核算！"
                ElseIf recAccount!lngAccountNatureID > 0 Then
                    ValidAccount2 = False
                    Msg = "结余分配科目不能是现金银行、应收应付及存货类科目！"
                End If
            Else
                ValidAccount2 = False
                Msg = "科目不存在！"
            End If
        End If
        Set recAccount = Nothing
        fraWizard(2).Tag = ""
        
        If ValidAccount2 Then
            SaveSet 1, "结余分配", "弥补亏损科目", ltxtAcc21.ID, True, "Long"
            SaveSet 1, "结余分配", "结余分配科目2", ltxtAcc22.ID, True, "Long"
        End If
        If ValidAccount2 Then
            ValidAccount2 = GenVoucher2
            If Not ValidAccount2 Then
                Msg = "弥补亏损凭证生成失败！"
            End If
        End If
    End Select
End Function

'第三步，凭证预览
Private Function ValidResult(Msg As String) As Boolean
    ValidResult = True
    
    If ExclusiveIn(Caption, mclsMainControl.LogID) Then
        If ValidResult Then
            If ltxtTemplate.ID = 0 Then
                ValidResult = False
                Msg = "未指定凭证模板！"
            End If
        End If
        If ValidResult Then
            If ltxtType.ID = 0 Then
                ValidResult = False
                Msg = "未指定凭证类型！"
            End If
        End If
        If ValidResult Then
            VoucherData(0).TemplateID = ltxtTemplate.ID
            VoucherData(0).VoucherTypeID = ltxtType.ID
            VoucherData(1).TemplateID = ltxtTemplate.ID
            VoucherData(1).VoucherTypeID = ltxtType.ID
            VoucherData(2).TemplateID = ltxtTemplate.ID
            VoucherData(2).VoucherTypeID = ltxtType.ID
            VoucherData(3).TemplateID = ltxtTemplate.ID
            VoucherData(3).VoucherTypeID = ltxtType.ID
        End If
    Else
        ValidResult = False
        stabWizard.Tab = mintStepNum - 1
    End If
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function GetTotalBalance() As Boolean
    Dim dtmEnd As Date
    Dim strSql As String
    Dim strCode As String
    Dim qrfBalance As rdoQuery
    Dim recLoss As rdoResultset
    Dim intDirection As Integer
    Dim strQAccountBalanceSql As String
    Dim strTmp As String
    
    strCode = AccountCode(ltxtAcc13.ID)
    If InStr(strCode, "-") > 0 Then
        strCode = Left$(strCode, InStr(strCode, "-") - 1)
    End If
    strSql = "SELECT intDirection FROM Account WHERE strAccountCode='" & strCode & "'"
    'Set recLoss = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
    Set recLoss = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recLoss.EOF Then
        intDirection = recLoss!intDirection
    End If
    recLoss.Close
    Set recLoss = Nothing
    If intDirection <> 1 And intDirection <> -1 Then
        GetTotalBalance = False
        Exit Function
    End If
    
    '结转期间
    gclsBase.PeriodOfDate gclsBase.BaseDate, , dtmEnd
'    strSql = "PARAMETERS EndDate Date;" _
'        & "SELECT SUM(dblPostedInit*intDirection+dblPostedDebit-dblPostedCredit) AS dblAmount " _
'        & "FROM QAccountBalance LEFT JOIN Account " _
'        & "ON QAccountBalance.lngAccountID=Account.lngAccountID " _
'        & "WHERE Instr(strAccountCode,'" & strCode & "-')=1"
'    Set qrfBalance = gclsBase.BaseDB.CreateQueryDef("", strSql)
'    With qrfBalance
'        .Parameters("EndDate") = dtmEnd
'        Set recLoss = .OpenRecordset(dbOpenSnapshot)
'    End With
    strQAccountBalanceSql = TransferPublic.getQAccountBalanceOraSql(Format(dtmEnd, "yyyy-mm-dd"))
    strSql = "SELECT SUM(dblPostedDebit-dblPostedCredit) AS dblAmount " _
        & "FROM ( " & strQAccountBalanceSql & " ) QAccountBalance,Account " _
        & "WHERE QAccountBalance.lngAccountID=Account.lngAccountID(+) " _
        & "AND Instr(strAccountCode,'" & strCode & "-')=1"
    Set recLoss = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recLoss.EOF Then
        mdblBalance13 = Format(recLoss!dblAmount, "@;0") * intDirection + mdblBalance13 * intDirection
    Else
        mdblBalance13 = mdblBalance13 * intDirection
    End If
    recLoss.Close
    Set recLoss = Nothing
'    qrfBalance.Close
'    Set qrfBalance = Nothing
    GetTotalBalance = True
End Function

'卡片新增（模板）
Private Sub ltxtTemplate_AddNew()
    Dim lngTemplateID As Long
    lngTemplateID = FrmNewTemplate.AddCard(, 1, 17, mlngFormatID, ltxtTemplate.ID)
    RefreshTemplate lngTemplateID
End Sub
Private Sub ltxtTemplate_Delete()
    If ltxtTemplate.ID > 0 Then
        If Card.DelCard(msgTemplate, ltxtTemplate.ID) Then
            RefreshTemplate
        Else
            ltxtTemplate.SeekId ltxtTemplate.ID
        End If
    End If
End Sub
Private Sub ltxtTemplate_Edit()
    If ltxtTemplate.ID > 0 Then
       Card.EditCard msgTemplate, ltxtTemplate.ID, , mlngFormatID
       RefreshTemplate ltxtTemplate.ID
    End If
End Sub
Private Sub ltxtTemplate_ItemNotExist()
    Dim lngID As Long
    If frmMsgAdd.MsgAddShow("增加凭证模板", "凭证模板“" & Trim(ltxtTemplate.Text) & "”不存在，是否新增?") = vbOK Then
        lngID = FrmNewTemplate.AddCard(ltxtTemplate.Text, 1, 17, mlngFormatID, ltxtTemplate.ID)
        RefreshTemplate lngID
    Else
        ltxtTemplate.Text = ""
    End If
End Sub


'卡片新增（凭证类型）
Private Sub ltxtType_AddNew()
    Dim lngID As Long
    lngID = Card.AddCard(msgVoucherType)
    RefreshVoucherType lngID
End Sub
Private Sub ltxtType_Delete()
    If ltxtType.ID > 0 Then
        If Card.DelCard(msgVoucherType, ltxtType.ID) Then
            RefreshVoucherType
        Else
            ltxtType.SeekId ltxtType.ID
        End If
    End If
End Sub
Private Sub ltxtType_Edit()
    If ltxtType.ID > 0 Then
        Card.EditCard msgVoucherType, ltxtType.ID
        RefreshVoucherType ltxtType.ID
    End If
End Sub
Private Sub ltxtType_ItemNotExist()
    Dim lngID As Long
    
    If frmMsgAdd.MsgAddShow("增加凭证类型", "凭证类型“" & Trim(ltxtType.Text) & "”不存在，是否新增?") = vbOK Then
        lngID = Card.AddCard(msgVoucherType, ltxtType.Text)
        RefreshVoucherType lngID
    Else
        ltxtType.Text = ""
    End If
End Sub


Private Sub RefreshVoucherType(Optional ByVal lngID As Long)
    If Not ltxtType.Recordset Is Nothing Then
        Utility.RemoveListRecordSet lrtVoucherType
    End If
    On Error Resume Next
    ltxtType.ClearRefer
    Set ltxtType.Recordset = Utility.GetListRecordSet(lrtVoucherType)
    ltxtType.Comparts = 2
    ltxtType.AddRefer "<新增>"
    ltxtType.AddRefer "<修改>"
    ltxtType.AddRefer "<删除>"
    If lngID > 0 Then
        ltxtType.SeekId lngID
    Else
        If Not ltxtType.Recordset Is Nothing Then
            'ltxtType.ReferRow = 4 + IIf(ltxtType.Recordset.RecordCount > 0, ltxtType.Recordset.RecordCount - 1, 0)
            ltxtType.ReferRow = 4 + IIf(ltxtType.Recordset.RowCount > 0, ltxtType.Recordset.RowCount - 1, 0)
        Else
            ltxtType.Text = ""
        End If
    End If
End Sub

Private Sub RefreshAccount(Optional intChoice As Integer)
    Dim lngAccountID As Long
    
    If intChoice = 0 Or intChoice = 11 Then
        lngAccountID = ltxtAcc11.ID
        If Not ltxtAcc11.Recordset Is Nothing Then
            Utility.RemoveListRecordSet lrtAccount
        End If
        On Error Resume Next
        ltxtAcc11.ClearRefer
        Set ltxtAcc11.Recordset = Utility.GetListRecordSet(lrtAccount)
        ltxtAcc11.Comparts = 1
        If lngAccountID > 0 Then
            ltxtAcc11.SeekId lngAccountID
        End If
    End If
    If intChoice = 0 Or intChoice = 12 Then
        lngAccountID = ltxtAcc12.ID
        If Not ltxtAcc12.Recordset Is Nothing Then
            Utility.RemoveListRecordSet lrtAccount
        End If
        On Error Resume Next
        ltxtAcc12.ClearRefer
        Set ltxtAcc12.Recordset = Utility.GetListRecordSet(lrtAccount)
        ltxtAcc12.Comparts = 1
        If lngAccountID > 0 Then
            ltxtAcc12.SeekId lngAccountID
        End If
    End If
    If intChoice = 0 Or intChoice = 13 Then
        lngAccountID = ltxtAcc13.ID
        If Not ltxtAcc13.Recordset Is Nothing Then
            Utility.RemoveListRecordSet lrtAccount
        End If
        On Error Resume Next
        ltxtAcc13.ClearRefer
        Set ltxtAcc13.Recordset = Utility.GetListRecordSet(lrtAccount)
        ltxtAcc13.Comparts = 1
        If lngAccountID > 0 Then
            ltxtAcc13.SeekId lngAccountID
        End If
    End If
    If intChoice = 0 Or intChoice = 21 Then
        lngAccountID = ltxtAcc21.ID
        If Not ltxtAcc21.Recordset Is Nothing Then
            Utility.RemoveListRecordSet lrtAccount
        End If
        On Error Resume Next
        ltxtAcc21.ClearRefer
        Set ltxtAcc21.Recordset = Utility.GetListRecordSet(lrtAccount)
        ltxtAcc21.Comparts = 1
        If lngAccountID > 0 Then
            ltxtAcc21.SeekId lngAccountID
        End If
    End If
    If intChoice = 0 Or intChoice = 22 Then
        lngAccountID = ltxtAcc22.ID
        If Not ltxtAcc22.Recordset Is Nothing Then
            Utility.RemoveListRecordSet lrtAccount
        End If
        On Error Resume Next
        ltxtAcc22.ClearRefer
        Set ltxtAcc22.Recordset = Utility.GetListRecordSet(lrtAccount)
        ltxtAcc22.Comparts = 1
        If lngAccountID > 0 Then
            ltxtAcc22.SeekId lngAccountID
        End If
    End If
    If intChoice = 0 Or intChoice = 31 Then
        lngAccountID = ltxtAcc31.ID
        If Not ltxtAcc31.Recordset Is Nothing Then
            Utility.RemoveListRecordSet lrtAccount
        End If
        On Error Resume Next
        ltxtAcc31.ClearRefer
        Set ltxtAcc31.Recordset = Utility.GetListRecordSet(lrtAccount)
        ltxtAcc31.Comparts = 1
        If lngAccountID > 0 Then
            ltxtAcc31.SeekId lngAccountID
        End If
    End If
    If intChoice = 0 Or intChoice = 32 Then
        lngAccountID = ltxtAcc32.ID
        If Not ltxtAcc32.Recordset Is Nothing Then
            Utility.RemoveListRecordSet lrtAccount
        End If
        On Error Resume Next
        ltxtAcc32.ClearRefer
        Set ltxtAcc32.Recordset = Utility.GetListRecordSet(lrtAccount)
        ltxtAcc32.Comparts = 1
        If lngAccountID > 0 Then
            ltxtAcc32.SeekId lngAccountID
        End If
    End If
    If intChoice = 0 Or intChoice = 33 Then
        lngAccountID = ltxtAcc33.ID
        If Not ltxtAcc33.Recordset Is Nothing Then
            Utility.RemoveListRecordSet lrtAccount
        End If
        On Error Resume Next
        ltxtAcc33.ClearRefer
        Set ltxtAcc33.Recordset = Utility.GetListRecordSet(lrtAccount)
        ltxtAcc33.Comparts = 1
        If lngAccountID > 0 Then
            ltxtAcc33.SeekId lngAccou