clsvouchermethod.cls

金算盘软件代码

        strSql = "SELECT lngVoucherID,lngPostID FROM Voucher WHERE (lngVoucherID)=" & lngVoucherID & " AND lngPostID = 0"
            Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
            If recTemp.BOF And recTemp.EOF Then
                cMsgBox "本张凭证已被他人记帐！ "
                Set recTemp = Nothing
                If blnBegin Then gclsBase.BaseWorkSpace.RollBacktrans
                Exit Function
                GoTo PostVoucherErr
            End If
            recTemp.Edit
                recTemp!lngPostID = gclsBase.OperatorID
            recTemp.Update
            recTemp.Close
            Set recTemp = Nothing
        '3)
        If ChangeAllAccount_from_Voucher("I", lngVoucherID) = False Then GoTo PostVoucherErr
        
        gclsBase.BaseWorkSpace.CommitTrans
        blnBegin = False
        PostVoucher = True
        '*****************************************************************************
    Else
        '可依据情况，给出不能记帐的原因
        If Not CanPost Then
            cMsgBox "您没有对" & strOperatorName & "制作的凭证进行记帐的权限！"
        ElseIf Not IsChecked Then cMsgBox strTip & "凭证没有复核，不能记帐！"
        Else: cMsgBox "不能对凭证记帐！"
        End If
    End If
        
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    Exit Function
PostVoucherErr:
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    If blnBegin Then gclsBase.BaseWorkSpace.RollBacktrans
    If Err.Number = 3197 Then  '
        cMsgBox "本张凭证已被他人修改！ "
    Else
        cMsgBox "凭证记帐时出错！"
    End If
    On Error GoTo 0
End Function

'取消凭证记帐
Public Function UnPostVoucher(lngVoucherID As Long, Optional blnNoMsg As Boolean, Optional argVoucher As String, Optional blnMulti As Boolean, Optional ByVal blnGetVoucherMsg As Boolean = True) As Boolean
    Dim strSql As String
    Dim strTip As String
    Dim recTemp As rdoResultset
    Dim i As Integer
    Dim strOperatorName As String
    Dim lngMaker As Long
    Dim blnBegin As Boolean
    
    If Trim(argVoucher) = "" Then
        strTip = "本张"
    Else
        strTip = argVoucher + "号"
    End If
    On Error GoTo UnPostVoucherErr
    If blnGetVoucherMsg Then
        If Not GetVoucherStatus(lngVoucherID, False) Then Exit Function
    End If
    
    '已结帐的凭证不能取消记帐
    If IsClosed Then
        If Not blnNoMsg Then cMsgBox strTip & "凭证已经结帐，不能取消记帐！", "凭证记帐取消"
        Exit Function
    End If
    '判断权限
    CanPost = False
    If blnMulti Then
        CanPost = True
    Else
        For i = 0 To UBound(arrRights_Post)
            If arrRights_Post(i) = oldlngOperatorID Then
                CanPost = True
                Exit For
            End If
        Next i
        If Not CanPost Then
            strSql = "SELECT strOperatorName FROM Operator  WHERE lngOperatorID=" & oldlngOperatorID
            Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If recTemp.BOF And recTemp.EOF Then
                Set recTemp = Nothing
                Exit Function
            End If
            strOperatorName = recTemp(1)
            Set recTemp = Nothing
        End If
    End If
       
    '有记帐权限的任何操作员都可以取消未结帐期间的已记帐凭证的记帐标志
    If CanPost Then
        
        '凭证处于未结帐期间，不能取消记帐
         If IsClosed Then
            If Not blnNoMsg Then
                cMsgBox strTip & "凭证已结帐，不能取消记帐！"
            End If
            Exit Function
        End If
        
        If Not blnNoMsg Then
            If ShowMsg(thehWnd, "您确实要取消记帐" & strTip & "凭证吗？", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "提示信息") <> IDYES Then Exit Function
        End If
        '********************************取消记帐凭证********************************
        gclsBase.BaseWorkSpace.BeginTrans
        blnBegin = True
        '1)
        If ChangeAllAccount_from_Voucher("D", lngVoucherID) = False Then GoTo UnPostVoucherErr
        '2)
        strSql = "SELECT lngVoucherID,lngPostID FROM Voucher WHERE (lngVoucherID)=" & lngVoucherID & " AND lngPostID > 0"
            Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
            If recTemp.BOF And recTemp.EOF Then
                cMsgBox "本张凭证已被他人取消记帐！ "
                Set recTemp = Nothing
                If blnBegin Then gclsBase.BaseWorkSpace.RollBacktrans
                Exit Function
            End If
            recTemp.Edit
                recTemp!lngPostID = 0
            recTemp.Update
            recTemp.Close
            Set recTemp = Nothing
        '3)
        If ChangeAllAccount_from_Voucher("I", lngVoucherID) = False Then GoTo UnPostVoucherErr
        
        gclsBase.BaseWorkSpace.CommitTrans
        blnBegin = False
        UnPostVoucher = True
        '*****************************************************************************
    Else
        If Not CanPost Then
            cMsgBox "您没有对" & strOperatorName & "制作的凭证进行取消记帐的权限！"
        Else
            cMsgBox "不能对凭证取消记帐！"
        End If
        Exit Function
    End If
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If

    Exit Function
UnPostVoucherErr:
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    If blnBegin Then gclsBase.BaseWorkSpace.RollBacktrans
    If Err.Number = 3197 Then  '
        cMsgBox "本张凭证已被他人修改！ "
    Else
        cMsgBox "凭证取消记帐时出错！"
    End If
    On Error GoTo 0
End Function

'多张复核
Public Function MultiCheckVoucher() As Boolean
    If CurrentPeriodIsClosed Then
        cMsgBox "当前会计期间已结帐，不能再复核当前会计期间的凭证！", "多张复核"
        Exit Function
    End If
    frmVoucherMultiList.SetFormType 0, thehWnd
    frmVoucherMultiList.BindingResultSet
End Function

'多张复核取消
Public Function MultiUnCheckVoucher() As Boolean
    If CurrentPeriodIsClosed Then
        cMsgBox "当前会计期间已结帐，不能再取消复核当前会计期间的凭证！", "多张复核取消"
        Exit Function
    End If
    frmVoucherMultiList.SetFormType 1, thehWnd
    frmVoucherMultiList.BindingResultSet
End Function

'多张记帐
Public Function MultiPostVoucher() As Boolean
    If CurrentPeriodIsClosed Then
        cMsgBox "当前会计期间已结帐，不能再记帐当前会计期间的凭证！", "多张记帐"
        Exit Function
    End If
    frmVoucherMultiList.SetFormType 2, thehWnd
    frmVoucherMultiList.BindingResultSet
End Function

'多张记帐取消
Public Function MultiUnPostVoucher() As Boolean
    If CurrentPeriodIsClosed Then
        cMsgBox "当前会计期间已结帐，不能再取消当前会计期间的凭证！", "多张记帐取消"
        Exit Function
    End If
    frmVoucherMultiList.SetFormType 3, thehWnd
    frmVoucherMultiList.BindingResultSet
End Function

'生成冲销凭证
Public Function GenCancelVoucher(lngVoucherID, Optional ByVal blnShowMsg As Boolean = True, Optional ByVal blnOperatorJustice As Boolean = False, Optional ByVal blnInCurrentPeriod As Boolean = False) As Boolean
    Dim strSql As String
    Dim recTemp As rdoResultset
    Dim recTemp_Gen As rdoResultset
    Dim intYear As Integer
    Dim bytPeriod As Integer
    Dim bytPeriod_Max As Integer
    Dim intVoucherNO As Integer
    Dim strVoucherTypeID As String
    Dim intYear_Next As Integer
    Dim bytPeriod_Next As Integer
    Dim strDate_Next As String
    Dim dtmVoucherDate As Date
    Dim i As Integer
    Dim lngVoucherID_Cancel As Long
    GenCancelVoucher = False
    On Error GoTo GenCancelVoucherErr
    strVoucherTypeID = ""
    intVoucherNO = 0
    '判断本凭证是否已有冲销凭证
    strSql = "SELECT lngSourceVoucherID From Voucher WHERE lngSourceVoucherID=" & lngVoucherID & " AND lngVoucherSourceID<=2"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recTemp.BOF Then
        Set recTemp = Nothing
'        If blnShowMsg Then
'            cMsgBox "本张凭证已生成过冲销凭证，不能再生成！"
'        End If
        GenCancelVoucher = True
        Exit Function
    End If
    Set recTemp = Nothing
    
    '查找下个会计期间的时间
    '1）生成冲销凭证头的信息
    
    strSql = "SELECT * From Voucher WHERE lngVoucherID=" & lngVoucherID
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recTemp.BOF And recTemp.EOF Then
        recTemp.Close
        Set recTemp = Nothing
        Exit Function
    End If
    '操作员判断
    If blnOperatorJustice Then
        If recTemp!lngOperatorID <> gclsBase.OperatorID Then
            Set recTemp = Nothing
            If blnShowMsg Then
                cMsgBox "不允许冲销其他操作员添制的凭证！"
            End If
            Exit Function
        End If
    End If
    dtmVoucherDate = CDate(recTemp!strDate)
    Set recTemp = Nothing
    
    intYear = gclsBase.FYearOfDate(dtmVoucherDate, , , bytPeriod)
    
    If blnInCurrentPeriod = False Then
        '取出下一个会计期间
        strSql = "SELECT intYear,bytPeriod,strStartDate,strEndDate FROM AccountPeriod " & _
            " WHERE (intYear> " & intYear & " OR (intYear= " & intYear & "  AND bytPeriod>" & bytPeriod & "))  ORDER BY intYear,bytPeriod"
        Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If recTemp.RowCount = 0 Then
            If blnShowMsg Then
                ShowMsg thehWnd, "帐套中未设置下一个会计期间，生成冲销凭证失败！", MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "错误提示"
            End If
            recTemp.Close
            Set recTemp = Nothing
            Exit Function
        End If
        intYear_Next = recTemp!intYear
        bytPeriod_Next = recTemp!bytPeriod
        strDate_Next = Format$(recTemp!strStartDate, "yyyy-mm-dd")
        recTemp.Close
        Set recTemp = Nothing
    Else    '在当前期间生成冲销凭证
        intYear_Next = intYear
        bytPeriod_Next = bytPeriod
        strDate_Next = dtmVoucherDate
    End If
    If blnShowMsg Then
        If ShowMsg(thehWnd, "您确实要生成" & intYear_Next & "年的第" & bytPeriod_Next & "个会计期间的冲销凭证吗？", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "提示信息") <> IDYES Then Exit Function
    End If
    strSql = "SELECT AccountPeriod.strStartDate From AccountPeriod WHERE intYear=" & intYear_Next & " AND bytPeriod=" & bytPeriod_Next
    
    '1）生成冲销凭证头的信息
    strSql = "SELECT * From Voucher WHERE Voucher.lngVoucherID=" & lngVoucherID
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recTemp.BOF And recTemp.EOF Then GoTo GenCancelVoucherErr
    
    Set recTemp_Gen = gclsBase.BaseDB.OpenResultset("SELECT * From Voucher WHERE lngVoucherID=0", rdOpenDynamic, rdConcurValues)
    recTemp.MoveFirst
    recTemp_Gen.AddNew
        For i = 1 To recTemp.rdoColumns.Count - 1
            recTemp_Gen(i) = recTemp(i)
        Next i
        '特殊信息
        recTemp_Gen!strDate = strDate_Next '紧接的下个会计期间的起始时间
        recTemp_Gen!lngVoucherSourceID = 2 '凭证来源ID：1 手工录入 2 自动冲销 3 损益结转 4 汇兑损益 5 应收单 6 应付单 7 收款单 8 付款单 9 采购单据 10 销售单据 11 库存单据 12 成本结转 13 工资结转 14 固资变动 15 计提折旧 16 通用转帐
        recTemp_Gen!lngSourceVoucherID = recTemp!lngVoucherID '冲销凭证的来源凭证ID
        recTemp_Gen!intYear = intYear_Next
        recTemp_Gen!bytPeriod = bytPeriod_Next
        recTemp_Gen!lngCheckerID = 0
        recTemp_Gen!lngPostID = 0
        recTemp_Gen!lngOperatorID = gclsBase.OperatorID
            strVoucherTypeID = CStr(recTemp!lngVoucherTypeID)
            intVoucherNO = GetMaxNO(intYear_Next, bytPeriod_Next, 41, strVoucherTypeID)
        recTemp_Gen!intVoucherNO = intVoucherNO
         '获得冲销凭证的ID
        lngVoucherID_Cancel = recTemp_Gen!lngVoucherID
    recTemp_Gen.Update
    
    Set recTemp = Nothing
    Set recTemp_Gen = Nothing
    
    '2）生成冲销凭证体的信息
    strSql = "SELECT * From VoucherDetail WHERE lngVoucherID=" & lngVoucherID
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recTemp.BOF And recTemp.EOF Then GoTo GenCancelVoucherErr
    
    Set recTemp_Gen = gclsBase.BaseDB.OpenResultset("SELECT * From VoucherDetail WHERE lngVoucherDetailID=0", rdOpenDynamic, rdConcurValues)
    recTemp.MoveFirst
    Do While Not recTemp.EOF
        recTemp_Gen.AddNew
        For i = 1 To recTemp.rdoColumns.Count - 1
            recTemp_Gen(i) = recTemp(i)
        Next i
        
        recTemp_Gen("lngVoucherID") = lngVoucherID_Cancel
        '数量和金额相反（为负）
        recTemp_Gen("dblAmount") = -1 * recTemp("dblAmount")
        recTemp_Gen("dblCurrencyAmount") = -1 * recTemp("dblCurrencyAmount")
        recTemp_Gen("dblQuantity") = -1 * recTemp("dblQuantity")
        recTemp_Gen.Update
        
        recTemp.MoveNext
    Loop
    Set recTemp = Nothing
    Set recTemp_Gen = Nothing
    
   
    '改变AccountDaily 和 AccountBalance
    If Not ChangeAllAccount_from_Voucher("I", lngVoucherID_Cancel) Then GoTo GenCancelVoucherErr

    GenCancelVoucher = True
    Exit Function
GenCancelVoucherErr:
    If blnShowMsg Then
            cMsgBox "生成冲销凭证失败！"
    End If
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    If Not recTemp_Gen Is Nothing Then
        Set recTemp_Gen = Nothing
    End If
End Function