frmtaskfinancecharge.frm

金算盘软件代码

                    lngDepartmentID = 0
                End If
                If mblnEmployee Then
                    lngEmployeeID = !lngEmployeeID
                Else
                    lngEmployeeID = 0
                End If
                If mblnClass1 Then
                    lngClassID1 = !lngClassID1
                Else
                    lngClassID1 = 0
                End If
                If mblnClass2 Then
                    lngClassID2 = !lngClassID2
                Else
                    lngClassID2 = 0
                End If
                AddArray lngRow, lngCustomerID, lngCurrencyID, lngDepartmentID, lngEmployeeID, _
                    lngClassID1, lngClassID2, dblResult
            End If
            dblCurrARAmount = 0
            .MoveNext
        Loop
    End With
End Function



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' 生成财务费用应收单据
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function GenBill() As Boolean
    Dim lngRow As Long
    Dim lngCustomerID As Long
    Dim lngCurrencyID As Long
    Dim dblTotal As Double
    Dim dblRate As Double

    GenBill = False
    If frmSetTaskPara.AccountID = 0 Then
        ShowMsg hwnd, "请设置利息收益科目！", vbInformation, Me.Caption
        cmdOK_Click 6
        Exit Function
    End If
    If ltxtTemplate.ID = 0 Then
        ShowMsg hwnd, "请设置单据模版！", vbInformation, Me.Caption
        Exit Function
    End If
    
    Me.MousePointer = vbHourglass
    
    gclsBase.BaseWorkSpace.BeginTrans
    
    For lngRow = 1 To msgTask.Rows - 1
        With msgTask
            dblTotal = GetValue(lngRow, mintColInterest)
            If .TextMatrix(lngRow, mintColCheck) = "√" And dblTotal > 0 Then
                lngCustomerID = GetValue(lngRow, mintColCustomerID)
                lngCurrencyID = GetValue(lngRow, mintColCurrencyID)
                GenBill = ProduceBill(lngCustomerID, lngCurrencyID, dblTotal)
                If Not GenBill Then
                    Exit For
                End If
            End If
        End With
    Next lngRow
    If GenBill Then
        gclsBase.BaseWorkSpace.CommitTrans
    Else
        'gclsBase.BaseWorkSpace.Rollback
        gclsBase.BaseWorkSpace.RollBacktrans
    End If
    Me.MousePointer = vbDefault
End Function

'将财务费用应收单的有关数据写回数据库
Private Function ProduceBill(lngCustomerID As Long, lngCurrencyID As Long, dblTotal As Double) As Boolean
    Dim dblAmount As Double
    Dim lngTermID As Long
    Dim lngActivityID As Long
    Dim lngARAccountID As Long
    Dim lngReceiptNo As Long
    Dim strReceiptDate As String
    Dim strDueDate As String
    Dim dblRate As Double
    Dim blnIsIndirect As Boolean
    Dim strSql As String
    Dim recTerm As rdoResultset
    Dim recActivity As rdoResultset
    Dim recActivityDetail As rdoResultset
    Dim recCustomer As rdoResultset
    Dim recCurrency As rdoResultset
    Dim intYear As Integer
    Dim bytPeriod As Integer
    Dim lngCnt As Long
    
    On Error GoTo ErrHandle
    
    dblRate = RateValue(lngCurrencyID, cldTaskDate.Text)
    strReceiptDate = Format(cldTaskDate.Text, "yyyy-mm-dd")
    strDueDate = Format(cldTaskDate.Text, "yyyy-mm-dd")
    If dblRate = 0 Or (dblRate = 1 And lngCurrencyID <> gclsBase.NaturalCurId) Then
        ShowMsg hwnd, "找不到" & CurrencyName(lngCurrencyID) & "对应汇率，无法生成计息单！", _
            vbInformation + vbOKOnly, Caption
        ProduceBill = False
        Exit Function
    End If
    intYear = gclsBase.FYearOfDate(strReceiptDate)
    If intYear = 0 Then
        ShowMsg hwnd, strReceiptDate & "没有对应会计期间，无法生成计息单！", _
            vbInformation + vbOKOnly, Caption
        ProduceBill = False
        Exit Function
    End If
    
    strSql = "SELECT * FROM Customer WHERE lngCustomerID=" & lngCustomerID
    Set recCustomer = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recCustomer.EOF Then
        lngTermID = 0
        lngARAccountID = recCustomer!lngARAccountID
        If lngARAccountID = 0 Then
            ShowMsg hwnd, "请先设置单位" & recCustomer!strCustomerCode & "：" & recCustomer!strCustomerName & "的应收科目！", _
                vbInformation + vbOKOnly, Caption
            ProduceBill = False
        End If
    End If
    If lngTermID > 0 Then
        strSql = "SELECT * FROM Term WHERE lngTermID=" & lngTermID
        Set recTerm = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recTerm.EOF Then
            strReceiptDate = Format$(cldTaskDate.Text, "yyyy-mm-dd")
            strDueDate = Format$(CDate(cldTaskDate.Text) + recTerm!intDueDay, "yyyy-mm-dd")
        End If
    End If
    
    strSql = "SELECT * FROM Currencys WHERE lngCurrencyID=" & lngCurrencyID
    Set recCurrency = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recCurrency.EOF Then
        blnIsIndirect = recCurrency!blnIsIndirect
    End If
    
    If lngARAccountID > 0 Then
        intYear = gclsBase.FYearOfDate(strReceiptDate)
        bytPeriod = gclsBase.PeriodOfDate(strReceiptDate)
        
        Set recActivity = gclsBase.BaseDB.OpenResultset("SELECT * FROM Activity", rdOpenDynamic, rdConcurRowVer, 64)
        Set recActivityDetail = gclsBase.BaseDB.OpenResultset("SELECT * FROM ActivityDetail", rdOpenDynamic, rdConcurRowVer, 64)
        For lngCnt = 0 To UBound(marrcustomer)
            If marrcustomer(lngCnt).lngCustomerID = lngCustomerID And marrcustomer(lngCnt).lngCurrencyID = lngCurrencyID Then
                lngReceiptNo = GetMaxNO(intYear, bytPeriod, rtFinanCharge, "FC", strReceiptDate)
                With recActivity
                    .AddNew
                    !intYear = intYear
                    !bytPeriod = bytPeriod
                    lngActivityID = GetNewID("Activity")
                    !lngActivityID = lngActivityID
                    !lngActivityTypeID = atFinanCharge
                    !lngReceiptTypeID = rtFinanCharge
                    !strReceiptNo = "FC"
                    !lngReceiptNo = lngReceiptNo
                    !lngTemplateID = ltxtTemplate.ID
                    !lngTermID = lngTermID
                    !strReceiptDate = strReceiptDate
                    !strDueDate = strDueDate
                    !strDate = Format(cldTaskDate.Text, "yyyy-mm-dd")
                    !lngOperatorID = gclsBase.OperatorID
                    !strDebitAccountCode = AccountCode(lngARAccountID, True)
                    !strCreditAccountCode = AccountCode(frmSetTaskPara.AccountID, True)
                    .Update
                End With
            
                With recActivityDetail
                    .AddNew
                    !lngActivityDetailID = GetNewID("ActivityDetail")
                    !lngActivityID = lngActivityID
                    !strRemark = "计提应收利息"
                    !lngAccountID = lngARAccountID
                    !lngCustomerID = lngCustomerID
                    !lngCurrencyID = lngCurrencyID
                    !lngDepartmentID = marrcustomer(lngCnt).lngDepartmentID
                    !lngEmployeeID = marrcustomer(lngCnt).lngEmployeeID
                    !lngClassID1 = marrcustomer(lngCnt).lngClassID1
                    !lngClassID2 = marrcustomer(lngCnt).lngClassID2
                    !dblRate = dblRate
                    !dblCurrAmount = marrcustomer(lngCnt).dblAmount
                    If lngCurrencyID = gclsBase.NaturalCurId Then
                        !dblAmount = marrcustomer(lngCnt).dblAmount
                    ElseIf Not blnIsIndirect Then
                        !dblAmount = AdjustDec(marrcustomer(lngCnt).dblAmount * dblRate, gclsBase.NaturalCurDec)
                    Else
                        !dblAmount = AdjustDec(marrcustomer(lngCnt).dblAmount / dblRate, gclsBase.NaturalCurDec)
                    End If
                    !blnIsReceipt = 1
                    .Update
                    .AddNew
                    !lngActivityDetailID = GetNewID("ActivityDetail")
                    !lngActivityID = lngActivityID
                    !strRemark = "计提应收利息"
                    !lngAccountID = frmSetTaskPara.AccountID
                    !lngCurrencyID = lngCurrencyID
                    !dblRate = dblRate
                    !dblCurrAmount = marrcustomer(lngCnt).dblAmount
                    If lngCurrencyID = gclsBase.NaturalCurId Then
                        dblAmount = marrcustomer(lngCnt).dblAmount
                    ElseIf Not blnIsIndirect Then
                        dblAmount = AdjustDec(marrcustomer(lngCnt).dblAmount * dblRate, gclsBase.NaturalCurDec)
                    Else
                        dblAmount = AdjustDec(marrcustomer(lngCnt).dblAmount / dblRate, gclsBase.NaturalCurDec)
                    End If
                    !dblAmount = dblAmount
                    !blnIsReceipt = 0
                    .Update
                End With
            End If
        Next lngCnt
        '将计提日期写回单位表
        If lngActivityID > 0 Then
            If Not mdlAccount.ChangeAllAccount_from_Invoice("I", lngActivityID) Then
                GoTo ErrHandle
            End If
            strSql = "UPDATE Customer SET strLastFCDate='" & Format(cldTaskDate.Text, "yyyy-mm-dd") & "' " _
                & "WHERE lngCustomerID=" & lngCustomerID
            gclsBase.ExecSQL strSql
            blnModifyMaxNO intYear, bytPeriod, rtFinanCharge, "FC", lngReceiptNo
        End If
        recActivity.Close
        Set recActivity = Nothing
        recActivityDetail.Close
        Set recActivityDetail = Nothing
    End If
    
    ProduceBill = True
    recCustomer.Close
    recCurrency.Close
    Set recCustomer = Nothing
    Set recCurrency = Nothing
    If lngActivityID > 0 And mlngActivityID = 0 Then
        mlngActivityID = lngActivityID
    End If
    Exit Function
    
ErrHandle:
    Set recCustomer = Nothing
    Set recCurrency = Nothing
End Function


'显示单据模版参照
Private Sub RefreshTemplate(Optional lngID As Long)
    Dim strSql As String
    Dim strCondVersion As String
    
    On Error Resume Next
    
    'strCondVersion = " And (bytVersion Mod " & gVersionType * 2 & ">=" & gVersionType & ")"
    strCondVersion = " And Mod(bytVersion, " & gVersionType * 2 & " ) >=" & gVersionType
    'StrSql = "SELECT lngTemplateID, strTemplateName  From Template " _
           & "Where lngReceiptTypeID = 38 And blnIsInActive=False " & strCondVersion _
           & " ORDER BY lngTemplateID"
    strSql = "SELECT lngTemplateID, strTemplateName  From Template " _
           & "Where lngReceiptTypeID = 38 And blnIsInActive=0 " & strCondVersion _
           & " ORDER BY lngTemplateID"
    ltxtTemplate.ClearRefer
    'Set ltxtTemplate.Recordset = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
    Set ltxtTemplate.Recordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    ltxtTemplate.Comparts = 2
    ltxtTemplate.AddRefer "<新增>"
    ltxtTemplate.AddRefer "<修改>"
    ltxtTemplate.AddRefer "<删除>"
    If lngID > 0 Then
        ltxtTemplate.SeekId lngID
    Else
        If Not ltxtTemplate.Recordset Is Nothing Then
            ltxtTemplate.ReferRow = 4
        Else
            ltxtTemplate.Text = ""
        End If
    End If
End Sub

Private Sub ltxtTemplate_AddNew()
    Dim lngID As Long

    lngID = FrmNewTemplate.AddCard(, 1, 14, 38, ltxtTemplate.ID, False)
    RefreshTemplate lngID
End Sub
Private Sub ltxtTemplate_Delete()
    If ltxtTemplate.ID > 0 Then
        If Card.DelCard(msgTemplate, ltxtTemplate.ID) Then
           RefreshTemplate
        End If
    End If
End Sub
Private Sub ltxtTemplate_Edit()
    If ltxtTemplate.ID > 0 Then
       Card.EditCard msgTemplate, ltxtTemplate.ID, , 38, False
       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, 14, 38, ltxtTemplate.ID)
        RefreshTemplate lngID
    Else
        ltxtTemplate.Text = ""
    End If
End Sub

Private Sub RefreshGrid()

    'On Error Resume Next

    msgTask.FixedCols = 0
    If Not mclsList.Grid Is Nothing Then
        Set mclsList.Grid = Nothing
    End If
    mclsList.ColOfs = 4
    Set mclsList.Grid = msgTask
    mclsList.ListSet.ViewId = 117
    'Set datAR.Recordset = GetTaskList()
    Set datAR.Resultset = GetTaskList()
    FindColPosition
    msgTask.ColWidth(1) = 0
    msgTask.ColWidth(2) = 0
    msgTask.ColWidth(3) = 450
    mclsList.SetupStyle
    mclsList.ListSetToGrid
    
    cmdOK(0).Enabled = (msgTask.Rows > msgTask.FixedRows)
    cmdOK(2).Enabled = (msgTask.Rows > msgTask.FixedRows)
    cmdOK(3).Enabled = (msgTask.Rows > msgTask.FixedRows)
    cmdOK(4).Enabled = (msgTask.Rows > msgTask.FixedRows)
    cmdOK(5).Enabled = (msgTask.Rows > msgTask.FixedRows)
    ReDim marrcustomer(0)
    marrcustomer(0).lngCustomerID = 0
    marrcustomer(0).lngCurrencyID = 0
    marrcustomer(0).dblAmount = 0
End Sub


Private Sub FindColPosition()
    mintColDate = GetGridCol("上次计息日期", msgTask)
    mintColCustomer = GetGridCol("单位", msgTask)
    mintColCurrency = GetGridCol("币种", msgTask)
    mintColAmount = GetGridCol("过期余额", msgTask)
    mintColInterest = GetGridCol("计提利息", msgTask)
End Sub

Private Function GetValue(lngRow As Long, intCol As Integer, Optional strType As String = "Double") As Variant
    GetValue = GetGridValue(lngRow, intCol, strType, msgTask)
End Function