clsvouchermethod.cls

金算盘软件代码

    Dim recTemp As rdoResultset
    Dim strOperatorName As String
    Dim strTip As String
    Dim blnBegin As Boolean
    
    Dim i As Integer
    Dim lngMaker As Long
    
    If Trim(argVoucher) = "" Then
        strTip = "本张"
    Else
        strTip = argVoucher + "号"
    End If
    
    'If Not GetAllID(lngVoucherID) Then Exit Function
    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
    If IsError Then
       If Not blnNoMsg Then cMsgBox strTip & "凭证有错，不能复核！", "凭证复核"
          Exit Function
    End If
    
    If IsVoid Then
       If Not blnNoMsg Then cMsgBox strTip & "凭证已经作废，不能复核！", "凭证复核"
          Exit Function
    End If
    
    
    '判断权限
    CanCheck = False
    If blnMulti Then
        CanCheck = True
    Else
        For i = 0 To UBound(arrRights_Check)
            If arrRights_Check(i) = oldlngOperatorID Then
                CanCheck = True
                Exit For
            End If
        Next i
        If CanCheck = False Then
            strSql = "SELECT strOperatorName FROM Operator  WHERE lngOperatorID = " & oldlngOperatorID
            Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If recTemp.BOF And recTemp.EOF Then
                Exit Function
            End If
    '        lngMaker = oldlngOperatorID
            strOperatorName = recTemp!strOperatorName
            Set recTemp = Nothing
        End If
    End If
    
On Error GoTo CheckVoucherErr
    '规则：无复核权限不能复核 ；不能复核自己制作的凭证
    If CanCheck And (oldlngOperatorID <> gclsBase.OperatorID) Then
        If Not blnNoMsg Then
            If ShowMsg(thehWnd, "您确实要复核" & strTip & "凭证吗？", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "提示信息") <> IDYES Then Exit Function
        End If
        '********************************复核凭证********************************
        '2)设置复核人的ID
'        strSql = "UPDATE Voucher SET Voucher.lngCheckerID = " & gclsBase.OperatorID & " WHERE (((Voucher.lngVoucherID)=" & lngVoucherID & "));"
'        If gclsBase.ExecSQL(strSql) = False Then GoTo CheckVoucherErr
        strSql = "SELECT lngVoucherID,lngCheckerID FROM Voucher WHERE (lngVoucherID)=" & lngVoucherID & " AND lngCheckerID = 0"
            Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
            If recTemp.BOF And recTemp.EOF Then
                cMsgBox "本张凭证已被他人复核！ "
                Set recTemp = Nothing
                Exit Function
                Set recTemp = Nothing
                Exit Function
            End If
            recTemp.Edit
                recTemp!lngCheckerID = gclsBase.OperatorID
            recTemp.Update
            recTemp.Close
            Set recTemp = Nothing
                
        CheckVoucher = True
        '************************************************************************
    Else
        '可依据情况，给出不能复核的原因
        If Not CanCheck Then
            cMsgBox "您没有复核" & strOperatorName & "制作的凭证的权限！"
        ElseIf oldlngOperatorID = gclsBase.OperatorID Then cMsgBox "不能复核自己制作的凭证！"
        Else
            cMsgBox "不能复核凭证！"
        End If
    End If

    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    Exit Function
CheckVoucherErr:
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    If Err.Number = 3197 Then  '
        cMsgBox "本张凭证已被他人修改！ "
    Else
        cMsgBox "复核凭证时出错！"
    End If
    On Error Resume Next
End Function

'取消复核凭证
Public Function UnCheckVoucher(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 blnBegin As Boolean
    Dim recTemp As rdoResultset
    
    If Trim(argVoucher) = "" Then
        strTip = "本张"
    Else
        strTip = argVoucher + "号"
    End If
    
'    If Not GetAllID(lngVoucherID) Then Exit Function
    If blnGetVoucherMsg Then
        If Not GetVoucherStatus(lngVoucherID, False) Then Exit Function
    End If
On Error GoTo UnCheckVoucherErr
    
    '已结帐的凭证不能取消复核
    If IsClosed Then
        If Not blnNoMsg Then cMsgBox strTip & "凭证已经结帐，不能取消复核！", "凭证复核取消"
        Exit Function
    End If
    
    If IsVoid Then
       If Not blnNoMsg Then cMsgBox strTip & "凭证已经作废，不能取消复核！", "凭证复核"
          Exit Function
    End If
    If IsPosted Then
        If Not blnNoMsg Then cMsgBox strTip & "凭证已经记帐，不能取消复核！", "凭证复核取消"
        Exit Function
    End If
    '取消复核只能由复核人取消
    If oldlngCheckerID = gclsBase.OperatorID Then
        If Not blnNoMsg Then
            If ShowMsg(thehWnd, "您确实要取消复核" & strTip & "凭证吗？", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "提示信息") <> IDYES Then Exit Function
        End If
        '********************************取消复核凭证********************************
        '1)
 '       If ChangeAccount(lngVoucherID, 2, 1) = False Then GoTo UnCheckVoucherErr
        '2)
 '       strSql = "UPDATE Voucher SET Voucher.lngCheckerID = 0 WHERE (((Voucher.lngVoucherID)=" & lngVoucherID & "));"
 '       If gclsBase.ExecSQL(strSql) = False Then GoTo UnCheckVoucherErr
        strSql = "SELECT lngVoucherID,lngCheckerID FROM Voucher WHERE (lngVoucherID)=" & lngVoucherID & " AND lngCheckerID > 0"
            Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
            If recTemp.BOF And recTemp.EOF Then
                cMsgBox "本张凭证已被他人取消复核！ "
                Set recTemp = Nothing
                Exit Function
                GoTo UnCheckVoucherErr
            End If
            recTemp.Edit
                recTemp!lngCheckerID = 0
            recTemp.Update
            recTemp.Close
            Set recTemp = Nothing
        UnCheckVoucher = True
        '*****************************************************************************
    Else
        '可依据情况，给出不能取消复核的原因
        If oldlngCheckerID <> lngVoucherID Then
            cMsgBox "取消复核只能由复核本人取消！"
        Else
            cMsgBox "不能取消复核！"
        End If
    End If
    
    Exit Function
UnCheckVoucherErr:
    If Err.Number = 3197 Then  '
        cMsgBox "本张凭证已被他人修改！ "
    Else
        cMsgBox "凭证取消复核时出错！"
    End If
    On Error Resume Next
End Function

'记帐/取消记帐
Public Function ChangePost(lngVoucherID As Long, argVoucher As String) As Boolean
    strVoucher = argVoucher
    
    If Not GetVoucherStatus(lngVoucherID, False) Then Exit Function
    If Not IsPosted Then
        If PostVoucher(lngVoucherID, , argVoucher, , False) Then
            ChangePost = True
            '如果列表有记帐人一项，则将本凭证的的记帐人一项置为当前操作员的名字
            SetVoucherItem "记帐", gclsBase.OperatorName, frmVoucherList.grdList.Row
        End If
    Else
        If UnPostVoucher(lngVoucherID, , argVoucher, , False) Then
            ChangePost = True
            '如果列表有记帐人一项，则将本凭证的的记帐人一项置为当前操作员的名字
            SetVoucherItem "记帐", "", frmVoucherList.grdList.Row
        End If
    End If
        
End Function
'测评版专用可记帐判断 Start-----------------------------------------------------------------------
Public Function blnPeriodCanPost(Optional ByVal AccountYear As Integer = 0, Optional ByVal AccountPeriod As Byte = 0) As Boolean
    Dim strSql As String
    Dim recTemp As rdoResultset
    #If conTest <> 1 Then
        blnPeriodCanPost = True
        Exit Function
    #Else
        blnPeriodCanPost = False
        If AccountYear <> 0 Then
            intYear = AccountYear
        End If
        If AccountPeriod <> 0 Then
            bytPeriod = AccountPeriod
        End If
        strSql = " SELECT * FROM AccountPeriod WHERE strEndDate>='" & Format$(gclsBase.BeginDate, "YYYY-MM-DD") & "' ORDER BY intYear,bytPeriod "
        
        Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If recTemp Is Nothing Then GoTo TheErr
        If recTemp.EOF And recTemp.BOF Then GoTo TheErr
        '找到当前期间
        Do While recTemp.EOF = False
            If recTemp!intYear = intYear And recTemp!bytPeriod = bytPeriod Then
                Exit Do
            End If
            recTemp.MoveNext
        Loop
        If recTemp.EOF Then GoTo TheErr
        '当前期间是否结帐
        If recTemp!lngCloseID > 0 Then GoTo TheErr
        '上一个期间是否结帐，如已结帐则本期可记帐
        recTemp.MovePrevious
        If recTemp.BOF Then GoTo CanPostExit            '无上一期间
        If recTemp!lngCloseID > 0 Then GoTo CanPostExit  '上一期间已结帐
        '上一期间未结帐
        If bytPeriod > 3 Then GoTo CanNotPost  '原期间>3则本期不可记帐
        '本期间为第一季度期间（1，2，3）
        If recTemp!intYear = intYear Then
            '此时recTemp!intYear只能是1或2
PrevPeriod:
            recTemp.MovePrevious
            If recTemp.BOF Then GoTo CanPostExit            '无上一期间
            If recTemp!lngCloseID > 0 Then GoTo CanPostExit  '上一期间已结帐
            
            If recTemp!intYear = intYear Then
                GoTo PrevPeriod
            Else
                GoTo LastPeriod
            End If
        Else
            '找到上一年度的最后期间
LastPeriod:
                If recTemp!lngCloseID > 0 Then GoTo CanPostExit '上一年度的最后期间已结帐
                '上一年度的最后期间未结帐
                recTemp.MovePrevious
                If recTemp.BOF Then GoTo CanPostExit '上一年度只有一个期间
                If recTemp!lngCloseID <= 0 Then GoTo CanNotPost
                GoTo CanPostExit
        End If
        
        
CanPostExit:
        If Not recTemp Is Nothing Then
            recTemp.Close
            Set recTemp = Nothing
        End If
        
        blnPeriodCanPost = True
        Exit Function
CanNotPost:
        If Not recTemp Is Nothing Then
            recTemp.Close
            Set recTemp = Nothing
        End If
        If AccountYear = 0 Then
            cMsgBox "前一个会计期间未结帐，本期记帐凭证不允许记帐！", "凭证记帐"
        End If
        blnPeriodCanPost = False
        Exit Function
TheErr:
        If Not recTemp Is Nothing Then
            Set recTemp = Nothing
        End If
        blnPeriodCanPost = False
        
#End If
End Function
'测评版专用可记帐判断  End-----------------------------------------------------------------------

'凭证记帐
Public Function PostVoucher(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 recTemp As rdoResultset
    Dim strOperatorName As String
    Dim strTip As String
    Dim i As Integer
    Dim lngMaker As Long
    Dim blnBegin As Boolean
    
    If Trim(argVoucher) = "" Then
        strTip = "本张"
    Else
        strTip = argVoucher + "号"
    End If
    If blnGetVoucherMsg Then
        If Not GetVoucherStatus(lngVoucherID, False) Then Exit Function
    End If
    On Error GoTo PostVoucherErr
    
    '已结帐的凭证不能记帐
    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 CanPost Then
            '测评版专用可记帐判断-----------------------------------------------------------------------
                If blnPeriodCanPost() = False Then Exit Function
            '-----------------------------------------------------------------------
        Else
            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!strOperatorName
            Set recTemp = Nothing
        End If
    End If

    '无记帐权限不能记帐
    '未复核的凭证不能记帐
    If CanPost And IsChecked Then
        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 PostVoucherErr
        '2)