account.bas

金算盘软件代码

Attribute VB_Name = "mdlAccount"
'作者：蔡奇科白扳３
'说明：
'本模块提供三种类型的接口:

'***********************************
 '修改人：肖志华  (Oracle 版) 1998/10/09
'***********************************

'各列表窗口对应编辑权限ID（王成USE）
Option Explicit
Public Enum frmRightsID
       
    frmListPurchaseOrderID = 50                        '采购订单
    
    frmListPurchaseID_1 = 52                           '商品采购
    frmListPurchaseID_2 = 54                           '直运采购
    frmListPurchaseID_3 = 56                           '受托入库
    frmListPurchaseID_4 = 58                           '受托结算
    frmListPurchaseID_5 = 106                          '加工入库
    frmListPurchaseID_6 = 108                          '加工费用
    frmListPurchaseID_7 = 62                           '采购发票
    frmListPurchaseID_8 = 96                           '自制入库
    frmListPurchaseID_9 = 129                          '盘盈入库
    frmListPurchaseID_10 = 98                          '其他入库
    
    frmListSalesOrderID = 68                          '销售订单
    
    frmListSalesID_11 = 70                            '商品销售
    frmListSalesID_12 = 72                            '直运销售
    frmListSalesID_13 = 74                            '委托出库
    frmListSalesID_14 = 76                            '委托结算
    frmListSalesID_15 = 104                           '加工出库
    frmListSalesID_16 = 82                            '分期出库
    frmListSalesID_17 = 84                            '分期结算
    frmListSalesID_18 = 124                           '销售发票
    frmListSalesID_19 = 100                           '领用出库
    frmListSalesID_20 = 126                           '成本调整
    frmListSalesID_21 = 130                           '盘亏出库
    frmListSalesID_22 = 102                           '其他出库
    
    frmListConsigneeID = 60                           '受托调价
    frmListLendAdjustID = 80                          '代销调拨
    frmListLendAdjustPriceID = 78                     '代销调价
    
    frmListAdjustID = 88                              '商品调拨
    frmListAdjustPriceID = 90                         '商品调价
    
    frmListComposeID = 94                             '商品组装 & 商品拆卸
    
    frmListCostPriceID = 110                          '入库成本
    frmListStockTakingID = 92                         '商品盘点
    
    frmInvoiceListID = 36                             '应收业务
    frmPayableListID = 40                             '应付业务
   
    frmReceiveListID = 45                             '付款单
    frmPaymentListID = 43                             '收款单
    
    frmVoucherListID = 28                             '记帐凭证
   
    frmListTransID = 31                               '通用转帐消息
    
    doTransID = 132 '执行转帐
End Enum
Public frmR(1) As Form '销售收款，采购付款

'参数：
'strOP ：“I”插入，“D”删除
'****   要实现修改功能，请先删除在新增  ****

'第1类:提供ItemActivity的ID 或 ItemActivityDeatilID 的ID 将一次全部处理本模块所涉及的2个余额（发生额）表
'Public Function ChangeAllAccount_from_Activity(strOP As String, lngActivityID As Long) As Boolean

'第2类：数据直接从数据库（ItemActivityDetail）中获得后改变余额表（或发生额表）

'Public Function ChangeAccountDaily(strOP As String, lngActivityDetailID As Integer) As Boolean

'第3类：数据不从数据库（ItemActivityDetail）中获得，数据由用户自己设置后改变余额表（或发生额表）
'（第二类接口被第一类接口从程序内部调用）

Public Function TableName(ByVal ReceiptType As Long) As String
        Select Case ReceiptType
        Case 56
            TableName = "Receive"
        Case 57
            TableName = "Polic"
        Case 58
            TableName = "Repair"
        Case 59
            TableName = "AccOpen"
        Case 60
            TableName = "AccClose"
        Case 61
            TableName = "Move"
        Case 62
            TableName = "Halt"
        Case 63
            TableName = "Enable"
        Case 64
            TableName = ""
        Case 65
            TableName = ""
        End Select
End Function
    
Public Sub ShowR_P(ByVal blnPayable As Boolean, Optional ByVal lngActivityID As Long = 0, Optional ByVal blnCancel As Boolean = False, Optional ByVal lngCustomerID As Long = 0, Optional ByVal lngItemActivityID As Long = 0)
    If blnPayable Then
        If frmR(1) Is Nothing Then
            Set frmR(1) = New frmR_P
        End If
        If lngActivityID > 0 Then
            frmR(1).ShowAOldBill 39, lngActivityID, blnCancel
        Else
            frmR(1).ShowANewTypeBill 39, lngCustomerID, lngItemActivityID
'            frmR(1).ShowANewTypeBill 39, 121, 142 ' lngCustomerID, lngItemActivityID
        End If
    Else
        If frmR(0) Is Nothing Then
            Set frmR(0) = New frmR_P
        End If
        If lngActivityID > 0 Then
            frmR(0).ShowAOldBill 40, lngActivityID, blnCancel
        Else
            frmR(0).ShowANewTypeBill 40, lngCustomerID, lngItemActivityID
        End If
    End If
End Sub
Public Function ChangeAllAccount_from_Activity(strOP As String, lngActivityID As Long) As Boolean
    Dim SqlStr As String
    Dim TmpQ As New rdoQuery
    Dim rec   As Boolean
    On Error GoTo EndProc
    
    SqlStr = "{ ? =  CALL " & gclsBase.UID & ".ChangeAllAccount_from_Activity( '" & strOP & "', " & lngActivityID & ") } "
    Set TmpQ.ActiveConnection = gclsBase.BaseDB
    TmpQ.SQL = SqlStr
    TmpQ(0).Type = rdTypeNUMERIC
    TmpQ(0).Direction = rdParamReturnValue
    TmpQ.Execute
    rec = IIf(TmpQ(0).Value = 0, True, False)
EndProc:
    Set TmpQ = Nothing
    ChangeAllAccount_from_Activity = rec
   
End Function


'改变一张凭证，自动处理Account 和 AccountBalance
Public Function ChangeAllAccount_from_Voucher(strOP As String, lngVoucherID As Long) As Boolean
    Dim SqlStr As String
    Dim TmpQ As New rdoQuery
    Dim rec   As Boolean
    On Error GoTo EndProc
    
    If gclsBase.ControlAccount Then
        SqlStr = "{ ? =   CALL " & gclsBase.UID & ".ChangeAllAccount_from_Voucher( '" & strOP & "', " & lngVoucherID & ",1) } "
    Else
        SqlStr = "{ ? =   CALL " & gclsBase.UID & ".ChangeAllAccount_from_Voucher( '" & strOP & "', " & lngVoucherID & ",0) } "
    End If
    Set TmpQ.ActiveConnection = gclsBase.BaseDB
    TmpQ.SQL = SqlStr
    TmpQ(0).Type = rdTypeNUMERIC
    TmpQ(0).Direction = rdParamReturnValue
    TmpQ.Execute
    rec = IIf(TmpQ(0).Value = 0, True, False)
EndProc:
    Set TmpQ = Nothing
    ChangeAllAccount_from_Voucher = rec

End Function
Public Function ChangeAllAccount_From_VoucherDetail(ByVal strOP As String, ByVal lngDetailID As Long) As Boolean
    Dim SqlStr As String
    Dim TmpQ As New rdoQuery
    Dim rec   As Boolean
    
    On Error GoTo EndProc
    
    If gclsBase.ControlAccount Then
        SqlStr = "{ ? =   CALL " & gclsBase.UID & ".ChangeAccount_from_VDetail( '" & strOP & "', " & lngDetailID & ",1) } "
    Else
        SqlStr = "{ ? =   CALL " & gclsBase.UID & ".ChangeAccount_from_VDetail( '" & strOP & "', " & lngDetailID & ",0) } "
    End If
    Set TmpQ.ActiveConnection = gclsBase.BaseDB
    TmpQ.SQL = SqlStr
    TmpQ(0).Type = rdTypeNUMERIC
    TmpQ(0).Direction = rdParamReturnValue
    TmpQ.Execute
    rec = IIf(TmpQ(0).Value = 0, True, False)
EndProc:
    Set TmpQ = Nothing
    ChangeAllAccount_From_VoucherDetail = rec
End Function

'改变一张应收/应付，收款/付款单，自动处理AccountDaily& AccountBanlance表
Public Function ChangeAllAccount_from_Invoice(strOP As String, lngActivityID As Long) As Boolean
    Dim SqlStr As String
    Dim TmpQ As New rdoQuery
    Dim rec   As Boolean
    On Error GoTo EndProc
    
    SqlStr = "{ ? =   CALL " & gclsBase.UID & ".ChangeAllAccount_from_Invoice( '" & strOP & "', " & lngActivityID & ") } "
    Set TmpQ.ActiveConnection = gclsBase.BaseDB
    TmpQ.SQL = SqlStr
    TmpQ(0).Type = rdTypeNUMERIC
    TmpQ(0).Direction = rdParamReturnValue
    TmpQ.Execute
    rec = IIf(TmpQ(0).Value = 0, True, False)
EndProc:
    Set TmpQ = Nothing
    ChangeAllAccount_from_Invoice = rec
End Function

''参数：
''intDirection：  1：改变AccountBalance的借方  -1：改变AccountBalance的贷方
''intFlag：       0：无凭证 1：未复核 2：已复核 3：已记帐
''dblCurrMoney    原币金额
''dblMoney As     本币金额
''dblQuantity     数量
''intYear
''lngAccountID
''lngCurrencyID
''lngJobID
''lngClassID1
''lngClassID2
''lngCustomerID
''lngDepartmentID
''lngEmployeeID
'Public Function NewAccountDaily(intDirection As Integer, intFlag As Integer, _
'                                                      strDate As String, lngAccountID As Long, lngCurrencyID As Long, _
'                                                      lngJobID As Long, lngClassID1 As Long, lngClassID2 As Long, _
'                                                      lngCustomerID As Long, lngDepartmentID As Long, _
'                                                      lngEmployeeID As Long, dblQuantity As Double, _
'                                                      dblCurrMoney As Double, dblMoney As Double) As Boolean
'        Dim SqlStr As String
'        Dim TmpQ As New rdoQuery
'        Dim rec As Boolean
'
'        SqlStr = "{ ? = CALL NewAccountDaily( " & intDirection & ", " & intFlag & ", " & dblQuantity & " , " _
'                     & dblCurrMoney & " , " & dblMoney & ", '" & strDate & "' , " & lngAccountID & " , " & lngCurrencyID & " , " _
'                     & lngJobID & " ,  " & lngClassID1 & " , " & lngClassID2 & " , " & lngCustomerID & " , " _
'                     & lngDepartmentID & " , " & lngEmployeeID & ") }"
'        Set TmpQ.ActiveConnection = gclsBase.BaseDB
'        TmpQ.sql = SqlStr
'        TmpQ(0).Type = rdTypeNUMERIC
'        TmpQ(0).Direction = rdParamReturnValue
'        TmpQ.Execute
'        rec = IIf(TmpQ(0).Value = 0, True, False)
'        Set TmpQ = Nothing
'        NewAccountDaily = rec
'End Function
'
'Public Function DeleteAccountDaily(intDirection As Integer, intFlag As Integer, strDate As String, lngAccountID As Long, lngCurrencyID As Long, lngJobID As Long, lngClassID1 As Long, lngClassID2 As Long, lngCustomerID As Long, lngDepartmentID As Long, lngEmployeeID As Long, dblQuantity As Double, dblCurrMoney As Double, dblMoney As Double) As Boolean
''On Error GoTo theErr
'    If NewAccountDaily(intDirection, intFlag, strDate, lngAccountID, lngCurrencyID, lngJobID, lngClassID1, lngClassID2, lngCustomerID, lngDepartmentID, lngEmployeeID, -1 * dblQuantity, -1 * dblCurrMoney, -1 * dblMoney) = False Then Exit Function
'    DeleteAccountDaily = True
'    Exit Function
'theErr:
'End Function
'
''                       *********************************
''                       *         AccountBalance        *
''                       *********************************
'
''当发生针对某会计科目的业务时，首先将业务发生额填入AccountDaily中，同时判断本次的发生额是否对会计科目余额表造成影响
''如果影响，则应改变会计科目余额表(accountBalance)
''注意：本次发生额仅可能影响本会计年的下面的会计年（不影响当前会计年)
''注意：发生额对会计余额的影响，可通过函数GetChangedInitValues_AccountBalance获得
'
''arrField_InitChange()arrValue_InitChange()：要改变下一会计年余额的字段和对应的值
''说明：
''----------------------------------------------------------------------------------------------------------------
''以下为删除期初单专用模块
''----------------------------------------------------------------------------------------------------------------
'
''//////////////////////////////////////////////////////////////
''应收、应付、收款、付款单中对余额处理程序
''/////////////////////////////////////////////////////////////
''新增或修改本期期初余额库
'Public Function NewBalance(ByVal lngActivityID As Long, ByVal lngReceiptTypeID As Long) As Boolean
'    Dim SqlStr As String
'    Dim TmpQ As New rdoQuery
'    Dim rec   As Boolean
'