clsvouchermethod.cls

金算盘软件代码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsVoucherMethod"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'蔡奇科
Option Explicit

'在已结帐时间范围内的凭证不能进行处理
Private strVoucher As String        '凭证号
Private strVoucher_Cancel As String '冲销凭证的凭证号

Public oldlngOperatorID As Long     '凭证的制单人
Public oldlngCheckerID  As Long     '凭证的复核人
Public lngVoucherSourceID As Long   '凭证来源
Public lngSourceVoucherID As Long   '来源凭证

Public IsChecked  As Boolean        '是否已复核
Public IsPosted   As Boolean        '是否已记帐
Public IsClosed   As Boolean        '是否已结帐
Public IsPrint    As Boolean        '打印标志
Public IsVoid     As Boolean        '作废标志
Public IsCancel   As Boolean        '冲销标志
Public IsError    As Boolean        '错误标志
Public strSourceVoucherCode    As String '源凭证号

Public CheckRights As Boolean       '复核权限
Public PostRights As Boolean        '记帐/取消记帐权限
Public CanCheck   As Boolean        '有无复核某张凭证的权限
Public CanPost    As Boolean        '有无记帐/取消记帐某张凭证的权限
Private thehWnd   As Long

Public intYear_Close   As Integer   '已结帐的最后年
Public bytPeriod_Close As Integer   '已结帐的最后会计期间
Private CurrentPeriodIsClosed As Boolean '当前会计期间是否已记帐
Public blnDeleted As Boolean             '当前凭证已被删除标志

Dim intFlag As Integer              '0：无凭证 1：未复核 2：已复核 3：已记帐
Dim dblAmount() As Double
Dim dblCurrencyAmount() As Double
Dim dblQuantity() As Double
Dim intYear As Integer '凭证会计年度
Dim bytPeriod As Byte   '凭证会计期间
Dim lngVoucherTypeID As Long
Dim intVoucherNO As Integer
'凭证权限
Dim arrRights_Make()  As Long '无用
Dim arrRights_Check() As Long '保存本人可复核/取消复核其他操作员的凭证的哪些操作员的ID（注意：数组不能包括当前操作员的ID:gclsBase.OperatorID,因为本人不能复核自己的凭证）
Dim arrRights_Post()  As Long '保存本人可记帐/取消记帐其他操作员的凭证的哪些操作员的ID
Dim lngCancelID() As Long     '冲消凭证ID

Public Sub SethWnd(arghWnd As Long)
    thehWnd = arghWnd
End Sub

Private Sub cMsgBox(strMsg As String, Optional strTitle As String)
    If Trim(strTitle) = "" Then
        strTitle = "提示信息"
    End If
    ShowMsg thehWnd, strMsg, MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL, strTitle
End Sub

'strColName: 要设置的列的表头名称
'strValue:   要显示的值
'lngRow:     当前行
Public Sub SetVoucherItem(strColName As String, ByVal strValue As String, lngRow As Long, Optional lngVoucherID As Long = 0, Optional CancelID As Long = 0)
    Dim i As Integer
    Dim intFindCol As Integer
    Dim bFound As Boolean
    
    With frmVoucherList.grdList
        For i = 1 To .Cols - 1
            If strColName = Trim(.TextArray(i)) Then
                intFindCol = i
                bFound = True
                Exit For
            End If
        Next i
            
        If Not bFound Then Exit Sub
        If lngVoucherID = 0 Then
           lngVoucherID = CLng(.TextArray(0 + frmVoucherList.grdList.Cols * lngRow))
        End If
        '从本行开始往上、往下找到所有ID相同的行，
        i = lngRow
        Do While i > 0
            If CLng(.TextArray(0 + frmVoucherList.grdList.Cols * i)) = lngVoucherID Then
                .TextMatrix(i, intFindCol) = strValue
                i = i - 1
            Else
                Exit Do
            End If
        Loop
        i = lngRow
        Do While i <= .Rows - 1
            If CLng(.TextArray(0 + frmVoucherList.grdList.Cols * i)) = lngVoucherID Then
                .TextMatrix(i, intFindCol) = strValue
                i = i + 1
            Else
                Exit Do
            End If
        Loop
        
        If CancelID <> 0 Then
            i = lngRow
            Do While i > 0
                If CLng(.TextArray(0 + frmVoucherList.grdList.Cols * i)) = lngVoucherID Then
                    .TextMatrix(i, intFindCol) = strValue
                    i = i - 1
                Else
                    Exit Do
                End If
            Loop
            i = lngRow
            Do While i <= .Rows - 1
                If CLng(.TextArray(0 + frmVoucherList.grdList.Cols * i)) = lngVoucherID Then
                    .TextMatrix(i, intFindCol) = strValue
                    i = i + 1
                Else
                    Exit Do
                End If
            Loop
        End If
    End With
End Sub

Public Sub HaveRights()
    Dim lngOperatorID As Long   '当前操作员
    On Error Resume Next
    lngOperatorID = gclsBase.OperatorID
    
    '获得当前操作员的权限
    ReDim arrRights_Make(0)
    ReDim arrRights_Check(0)
    ReDim arrRights_Post(0)
    arrRights_Check(0) = 0
    arrRights_Post(0) = 0
    GetGroupOperator lngOperatorID, arrRights_Make(), arrRights_Check(), arrRights_Post()
    
    CheckRights = True
    PostRights = True
    If UBound(arrRights_Check) = 0 Then
        If IsNull(arrRights_Check(0)) = False Then
            If arrRights_Check(0) < 1 Then
                CheckRights = False
            End If
        Else
            CheckRights = False
        End If
    End If
        
    If UBound(arrRights_Post) = 0 Then
        If IsNull(arrRights_Post(0)) = False Then
            If arrRights_Post(0) < 1 Then
                PostRights = False
            End If
        Else
            PostRights = False
        End If
    End If
    
End Sub

'类初始化时，根据当前操作员的ID，判断其的权限
Private Sub Class_Initialize()
    Dim strSql As String
    Dim recTemp As rdoResultset
    Dim intYeat As Integer
    Dim bytPeriod As Integer
    On Error Resume Next
    HaveRights
    
    '找出已结帐的最大会计年度和期间
    strSql = "SELECT AccountPeriod.intYear, AccountPeriod.bytPeriod FROM AccountPeriod Where (((AccountPeriod.lngCloseID) > 0)) ORDER BY AccountPeriod.intYear DESC , AccountPeriod.bytPeriod DESC"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recTemp.EOF Then
        recTemp.MoveFirst
        intYear_Close = recTemp!intYear
        bytPeriod_Close = recTemp!bytPeriod
    Else
        intYear_Close = 0
        bytPeriod_Close = 0
    End If
    recTemp.Close
    Set recTemp = Nothing
    
    '判断当前会计期间是否已结帐
    CurrentPeriodIsClosed = gclsBase.PeriodIsClosed(gclsBase.AccountYear, gclsBase.Period)

End Sub

'返回某张凭证的制单人，复核人,凭证的来源
Public Function GetAllID(lngVoucherID As Long) As Boolean
    GetAllID = GetVoucherStatus(lngVoucherID, False)
End Function

'获取当前的凭证状态
'因为msFlexGrid列是可选的，不能保证这6个状态列都出现在msFlexGrid中，所以不能直接从msFlexGrid获得信息，必须从数据库中获取信息
Public Function GetVoucherStatus(lngVoucherID As Long, Optional blnForDelete As Boolean = True) As Boolean
    Dim strSql As String
    Dim recTemp As rdoResultset
    Dim i As Long
    On Error GoTo TheErr
    IsChecked = False
    IsPosted = False
    IsPrint = False
    IsCancel = False
    IsError = False
    IsVoid = False
    IsClosed = False
    blnDeleted = False
    If lngVoucherID = 0 Then Exit Function
    strSql = "SELECT * From Voucher WHERE lngVoucherID=" & lngVoucherID
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recTemp.BOF And recTemp.EOF Then
        oldlngOperatorID = 0
        oldlngCheckerID = 0
        lngVoucherSourceID = 0
        strSourceVoucherCode = ""
        lngSourceVoucherID = 0
        Set recTemp = Nothing
        GetVoucherStatus = False
        blnDeleted = True
        Exit Function
    End If
    With recTemp
        If !lngCheckerID <> 0 Then IsChecked = True
        If !lngPostID <> 0 Then IsPosted = True
        If !blnIsPrint <> 0 Then IsPrint = True
        If !blnIsError <> 0 Then IsError = True
        If !blnIsVoid <> 0 Then IsVoid = True
        oldlngOperatorID = !lngOperatorID   '凭证制单人
        oldlngCheckerID = !lngCheckerID    '凭证复核人
        lngVoucherSourceID = !lngVoucherSourceID '凭证来源
        lngSourceVoucherID = !lngSourceVoucherID '来源凭证
        intYear = !intYear
        bytPeriod = !bytPeriod
        lngVoucherTypeID = !lngVoucherTypeID
        intVoucherNO = !intVoucherNO
    End With
    
    '判断本张凭证是否处于已结帐时间范围
    If intYear < intYear_Close Then
        IsClosed = True
    End If
    If intYear = intYear_Close And bytPeriod <= bytPeriod_Close Then
        IsClosed = True
    End If
   
    If blnForDelete Then
        '是否有冲销凭证 如果凭证已冲销，获得冲销凭证的凭证号
        strVoucher_Cancel = ""
        strSql = "SELECT LPAD(Voucher.intYear,4,'0') || '-' || LPAD(Voucher.bytPeriod,2,'0') || VoucherType.strVoucherTypeCode || LPAD(Voucher.intVoucherNO,4,'0') 凭证号,Voucher.lngVoucherID " & _
                " From Voucher, VoucherType " & _
                " WHERE VoucherTYpe.lngVoucherTypeID = Voucher.lngVoucherTypeID AND (Voucher.lngVoucherSourceID)<=2 AND (Voucher.lngSourceVoucherID)=" & lngVoucherID
        Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If recTemp Is Nothing Then GoTo TheErr
        If recTemp.BOF And recTemp.EOF Then
            ReDim lngCancelID(0)
            IsCancel = False
        Else
            IsCancel = True
            recTemp.MoveLast
            recTemp.MoveFirst
            ReDim lngCancelID(recTemp.RowCount)
            i = 0
            Do While recTemp.EOF = False
                If strVoucher_Cancel <> "" Then strVoucher_Cancel = strVoucher_Cancel & "，"
                strVoucher_Cancel = strVoucher_Cancel & recTemp(0)
                
                lngCancelID(i) = recTemp!lngVoucherID
                i = i + 1
                
                recTemp.MoveNext
            Loop
        End If
        If lngVoucherSourceID <= 2 And lngSourceVoucherID <> 0 Then
            '是冲消凭证,找源凭证的凭证号
            strSql = "SELECT Voucher.intYear,Voucher.bytPeriod,VoucherType.strVoucherTypeCode,Voucher.intVoucherNO " & _
                 "From Voucher ,VoucherType " & _
                 "WHERE Voucher.lngVoucherTypeID=VoucherType.lngVoucherTypeID AND (Voucher.lngVoucherID)= " & lngSourceVoucherID
            Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If recTemp.BOF And recTemp.EOF Then
                strSourceVoucherCode = ""
            Else
                strSourceVoucherCode = recTemp!intYear & "-" & Format(recTemp!bytPeriod, "00") & "-" & recTemp!strVoucherTypeCode & Format(recTemp!intVoucherNO, "0000")
            End If
        End If
    Else
        IsCancel = False
        strSourceVoucherCode = ""
    End If
    recTemp.Close
    Set recTemp = Nothing
    GetVoucherStatus = True
TheErr:
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
End Function

''通过凭证ID改变AccountBalance & AccountDaily
'Private Function ChangeAccount(lngVoucherID As Long, intFlag_Del As Integer, intFlag_New As Integer) As Boolean
'    Dim strSql As String
'    Dim recTemp As rdoResultset
'    Dim intDirection As Integer
'    Dim intYear As Integer
'    Dim i As Integer
'    On Error GoTo TheErr
'    strSql = "SELECT VoucherDetail.*, Voucher.strDate, Voucher.intYear " & _
'             "FROM Voucher INNER JOIN VoucherDetail ON Voucher.lngVoucherID = VoucherDetail.lngVoucherID " & _
'             "WHERE (((VoucherDetail.lngVoucherID)=" & lngVoucherID & "))"
'    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'    If recTemp.BOF And recTemp.EOF Then GoTo TheErr '无凭证明细
'    intYear = recTemp("intYear") '
'
'    recTemp.MoveFirst
'    Do While Not recTemp.EOF
'        intDirection = recTemp("intDirection")
'        '1)减去当前状态的数量
'        If Not DeleteAccountDaily(intDirection, intFlag_Del, recTemp("strDate"), recTemp("lngAccountID"), recTemp("lngCurrencyID"), recTemp("lngClassID1"), recTemp("lngClassID2"), recTemp("lngCustomerID"), recTemp("lngDepartmentID"), recTemp("lngEmployeeID"), recTemp("dblQuantity"), recTemp("dblCurrencyAmount"), recTemp("dblAmount")) Then Exit Function
'        '2)加上改变状态后的数量
'        If Not NewAccountDaily(intDirection, intFlag_New, recTemp("strDate"), recTemp("lngAccountID"), recTemp("lngCurrencyID"), recTemp("lngClassID1"), recTemp("lngClassID2"), recTemp("lngCustomerID"), recTemp("lngDepartmentID"), recTemp("lngEmployeeID"), recTemp("dblQuantity"), recTemp("dblCurrencyAmount"), recTemp("dblAmount")) Then Exit Function
'
'        recTemp.MoveNext
'    Loop
'
'    Set recTemp = Nothing
'    ChangeAccount = True
'    Exit Function
'TheErr:
'    If Not recTemp Is Nothing Then
'        Set recTemp = Nothing
'    End If
'End Function


'编辑凭证
Public Function EditVoucher(lngVoucherID As Long) As Boolean
    
'    If Not GetAllID(lngVoucherID) Then Exit Function
    If Not GetVoucherStatus(lngVoucherID, False) Then Exit Function
    
    '已复核或已记帐的凭证不允许修改
    '不能对别人填制的凭证进行修改操作
    '机制凭证只能删除不能修改
    If Not IsChecked And Not IsPosted And (oldlngOperatorID = gclsBase.OperatorID) And (lngVoucherSourceID = 1) Then
        EditVoucher = True
        Exit Function
    Else
        '可依据情况，给出不能修改的原因
        If IsPosted Then