frmtaskfinancecharge.frm

金算盘软件代码

'根据计提日期的变化刷新应收资料窗体
Private Sub cldTaskDate_LostFocus()
    Dim lngRow As Long

    If CDate(cldTaskDate.Text) <> mdtmDate Then
        mdtmDate = CDate(cldTaskDate.Text)
        RefreshGrid
        With msgTask
            .Redraw = False
            For lngRow = 1 To .Rows - 1
                If .TextMatrix(lngRow, mintColCheck) = "√" Then
                    ComputeInterest lngRow
                End If
            Next lngRow
            .Redraw = True
        End With
    End If
    mdtmDate = CDate(cldTaskDate.Text)
End Sub

'按钮数组的click事件处理
Private Sub cmdOK_Click(Index As Integer)
    Select Case Index
        Case 0
            '确定
            PressCmdOK
        Case 1
            '取消
            mblnExit = True
            Unload Me
        Case 2
            '应收资料
            PressCmdAR
        Case 3
            '全选
            PressCmdSelAll
        Case 4
            '条件选择
            PressCmdSelFil
        Case 5
            '全部取消
            PressCmdAllCancel
        Case 6
            '参数设置
            cmdOK(6).Enabled = False
            PressCmdParaSet
            If frmSetTaskPara.Changed Then
                RefreshGrid
            End If
            cmdOK(6).Enabled = True
    End Select
End Sub

'全部取消
Private Sub PressCmdAllCancel()
    Dim lngCnt As Long

    For lngCnt = 1 To msgTask.Rows - 1
        msgTask.TextMatrix(lngCnt, mintColCheck) = ""
        msgTask.TextMatrix(lngCnt, mintColInterest) = ""
        SubArray lngCnt, GetValue(lngCnt, mintColCustomerID), GetValue(lngCnt, mintColCurrencyID)
    Next lngCnt
End Sub

'显示当前单位的应收资料
Private Sub PressCmdAR()
    Dim lngCustomerID As Long
    Dim lngCurrencyID As Long
    Dim intDec As Integer
    
    With msgTask
        lngCustomerID = GetValue(.Row, mintColCustomerID)
        lngCurrencyID = GetValue(.Row, mintColCurrencyID)
        intDec = GetValue(.Row, mintColCurrencyDec)
    End With

    With frmARDetail
        .ShowDetail lngCustomerID, lngCurrencyID, cldTaskDate.Text, intDec
    End With
End Sub

'生成单据
Private Sub PressCmdOK()
    Dim lngRow As Long
    
    If chkProBill.Value Then
        With msgTask
            For lngRow = 1 To .Rows - 1
                If .TextMatrix(lngRow, mintColCheck) = "√" And C2Dbl(.TextMatrix(lngRow, mintColInterest)) > 0 Then
                    Exit For
                End If
            Next lngRow
        End With
        If lngRow < msgTask.Rows Then
            If GenBill() Then
                If mlngActivityID > 0 Then
                    gclsSys.SendMessage Me.hwnd, msgReceipt36
                    mblnExit = True
                    Unload Me
                    BillPublic.ShowBill atFinanCharge, mlngActivityID
                End If
            End If
        Else
            mblnExit = True
            Unload Me
        End If
    Else
        mblnExit = True
        Unload Me
    End If
End Sub

'显示财务费用参数设置窗体
Private Sub PressCmdParaSet()
    If Not frmSetTaskPara.Visible Then
       frmSetTaskPara.Show vbModal
    End If
End Sub

'全选
Private Sub PressCmdSelAll()
    Dim lngCnt As Long
    
    MsgForm.PleaseWait "正在计算利息，请稍后..."
    With msgTask
        For lngCnt = 1 To .Rows - 1
            .TextMatrix(lngCnt, mintColCheck) = "√"
            ComputeInterest lngCnt
        Next lngCnt
    End With
    Unload MsgForm
End Sub

'条件选择
Private Sub PressCmdSelFil()
    Dim lngCnt As Long
    Dim recFilter As rdoResultset
    Dim strCond As String
    Dim blnOK As Boolean
    
    On Error Resume Next
    mclsList.ListSet.ViewId = MyViewID
    If mclsList.ListSet.ListID < 1 Then
        mclsList.ListSet.SaveList
    End If
    strCond = Filter.ShowFilter(mclsList.ListSet.ListID, 1, , , , , blnOK, , "条件选择")
    If blnOK Then
'        Set recFilter = GetTaskList(strCond)
'        If Not recFilter Is Nothing Then
'            With msgTask
'                For lngCnt = .FixedRows To .Rows - 1
'                    recFilter.FindFirst "lngCustomerID=" & .TextMatrix(lngCnt, mintColCustomerID) _
'                        & " AND lngCurrencyID=" & .TextMatrix(lngCnt, mintColCurrencyID)
'                    If Not recFilter.NoMatch Then
'                        .TextMatrix(lngCnt, mintColCheck) = "√"
'                        ComputeInterest lngCnt
'                     Else
'                        .TextMatrix(lngCnt, mintColCheck) = ""
'                        .TextMatrix(lngCnt, mintColInterest) = ""
'                        SubArray lngCnt, GetValue(lngCnt, mintColCustomerID), GetValue(lngCnt, mintColCurrencyID)
'                    End If
'                Next lngCnt
'            End With
'            recFilter.Close
'            Set recFilter = Nothing
            With msgTask
                For lngCnt = .FixedRows To .Rows - 1
                    If Trim(strCond) <> "" Then
                        strCond = strCond & " AND lngCustomerID=" & .TextMatrix(lngCnt, mintColCustomerID) _
                            & " AND lngCurrencyID=" & .TextMatrix(lngCnt, mintColCurrencyID)
                    Else
                        strCond = "lngCustomerID = " & .TextMatrix(lngCnt, mintColCustomerID) _
                          & " AND lngCurrencyID=" & .TextMatrix(lngCnt, mintColCurrencyID)
                    End If
                    Set recFilter = GetTaskList(strCond)
                    If Not recFilter Is Nothing Then
                        If Not recFilter.EOF Then
                            .TextMatrix(lngCnt, mintColCheck) = "√"
                            ComputeInterest lngCnt
                        Else
                            .TextMatrix(lngCnt, mintColCheck) = ""
                            .TextMatrix(lngCnt, mintColInterest) = ""
                            SubArray lngCnt, GetValue(lngCnt, mintColCustomerID), GetValue(lngCnt, mintColCurrencyID)
                        End If
                        recFilter.Close
                        Set recFilter = Nothing
                    End If
                Next lngCnt
            End With
    End If
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' 计算利息
'
' 参数：GRID 行
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub ComputeInterest(ByVal lngRow As Long)
    Dim lngCusID As Long
    Dim lngCurrID As Long
    Dim dblResult As Double
    Dim strDate As String
    Dim intDec As Integer
    
    Me.MousePointer = vbHourglass
    
    With msgTask
        '取单位ID,币种ID
        lngCusID = GetValue(lngRow, mintColCustomerID)
        lngCurrID = GetValue(lngRow, mintColCurrencyID)
        strDate = GetValue(lngRow, mintColDate, "String")
        intDec = GetValue(lngRow, mintColCurrencyDec)
        '调用Calculate函数计算财务费用
        dblResult = Calculate(lngCusID, lngCurrID, strDate, intDec, lngRow)

        '显示计算结果
        If dblResult <> 0 Then
            If dblResult < frmSetTaskPara.MinRate Then
                If CBool(GetSet(1, "应收计息", "对于不足最小利息的按照最小利息收取", True)) Then
                    dblResult = frmSetTaskPara.MinRate
                End If
            End If
            .TextMatrix(lngRow, mintColInterest) = dblResult
            mclsList_AfterRefresh lngRow
        End If
    End With
    
    Me.MousePointer = vbDefault
End Sub

'计算某单位、币种的财务费用
Private Function Calculate(ByVal lngCusID As Long, ByVal lngCurrID As Long, ByVal strLastDate As String, _
    ByVal intDec As Integer, ByVal lngRow As Long) As Double
    Dim strSql As String
    Dim dblCurrCashAmount As Double
    Dim dblCurrARAmount As Double
    Dim recARDetail As rdoResultset
    Dim recCashDetail As rdoResultset

    '产生应收金额的业务明细
    strSql = "SELECT * FROM QARDetail " _
        & "WHERE dblCurrAmount>0 AND lngCustomerID=" & lngCusID _
        & " AND lngCurrencyID=" & lngCurrID
    '判断是否计算复利
    If Not frmSetTaskPara.Duplicate Then
        strSql = strSql & " AND lngReceiptTypeID<>38"
    End If
    If frmSetTaskPara.ByDueDay Then
        strSql = strSql & " AND strDueDate<'" & cldTaskDate.Text & "' "
    Else
        strSql = strSql & " AND strReceiptDate<'" & cldTaskDate.Text & "' "
    End If
    strSql = strSql & " ORDER BY strDate"
    'Set recARDetail = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenDynaset)
    Set recARDetail = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurRowVer, 64)

    '若计息基数为应收余额,则将预付款明细的
    '合计按时间先后冲减应收金额的业务明细
    If frmSetTaskPara.ByARBalance Then
        strSql = "SELECT QARDetail.dblCurrAmount*(-1) As dblCurrAmount " _
            & "FROM QARDetail " _
            & "WHERE dblCurrAmount<0 AND lngCustomerID=" & lngCusID _
            & " AND lngCurrencyID=" & lngCurrID
        '判断是否计算复利
        If Not frmSetTaskPara.Duplicate Then
            strSql = strSql & " AND lngReceiptTypeID<>38"
        End If
        If frmSetTaskPara.ByDueDay Then
            strSql = strSql & " AND strDueDate<'" & cldTaskDate.Text & "' "
        Else
            strSql = strSql & " AND strReceiptDate<'" & cldTaskDate.Text & "' "
        End If
        strSql = strSql & " ORDER BY strDate"
        'Set recCashDetail = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
        Set recCashDetail = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recCashDetail.EOF Then
            recCashDetail.MoveFirst
            dblCurrCashAmount = recCashDetail!dblCurrAmount
            dblCurrARAmount = recARDetail!dblCurrAmount
            Do While dblCurrCashAmount > 0
                If dblCurrARAmount > dblCurrCashAmount Then
                    dblCurrARAmount = dblCurrARAmount - dblCurrCashAmount
                    dblCurrCashAmount = 0
                Else
                    dblCurrCashAmount = dblCurrCashAmount - dblCurrARAmount
                    dblCurrARAmount = 0
                End If
                If dblCurrCashAmount = 0 Then
                    recCashDetail.MoveNext
                    If Not recCashDetail.EOF Then
                        dblCurrCashAmount = recCashDetail!dblCurrAmount
                    Else
                        Exit Do
                    End If
                End If
                If dblCurrARAmount = 0 Then
                    recARDetail.MoveNext
                    If Not recARDetail.EOF Then
                        dblCurrARAmount = recARDetail!dblCurrAmount
                    Else
                        Exit Do
                    End If
                End If
            Loop
        End If
    End If

    '调用DoCompute函数计算业务明细的财务费用
    If Not recARDetail.EOF Then
        ResetAttribute lngCusID
        Calculate = DoCompute(recARDetail, dblCurrARAmount, strLastDate, intDec, lngRow)
    End If
End Function


'计算每一笔业务的财务费用
Private Function DoCompute(recARDetail As rdoResultset, ByVal dblCurrARAmount As Double, ByVal strLastDate As String, _
    ByVal intDec As Integer, ByVal lngRow As Long) As Double
    Dim lngDays As Long
    Dim lngCalcDays As Long
    Dim dblResult As Double
    Dim lngCustomerID As Long
    Dim lngCurrencyID As Long
    Dim lngDepartmentID As Long
    Dim lngEmployeeID As Long
    Dim lngClassID1 As Long
    Dim lngClassID2 As Long
    
    On Error Resume Next
    
    DoCompute = 0
    With recARDetail
        Do While Not .EOF
            If dblCurrARAmount = 0 Then
                dblCurrARAmount = !dblCurrAmount
            End If
            If frmSetTaskPara.ByDueDay Then
                lngDays = DateDiff("d", CDate(!strDueDate), CDate(cldTaskDate.Text))
            Else
                lngDays = DateDiff("d", CDate(!strReceiptDate), CDate(cldTaskDate.Text))
            End If
            If lngDays > frmSetTaskPara.Days Then
                If IsDate(strLastDate) Then
                    lngCalcDays = DateDiff("d", CDate(strLastDate), CDate(cldTaskDate.Text))
                    If lngDays > lngCalcDays Then lngDays = lngCalcDays
                End If
                dblResult = dblCurrARAmount * lngDays * frmSetTaskPara.RateOfYear * 0.01 / 365
                dblResult = AdjustDec(dblResult, intDec)
                DoCompute = DoCompute + dblResult
                
                lngCustomerID = !lngCustomerID
                lngCurrencyID = !lngCurrencyID
                If mblnDepartment Then
                    lngDepartmentID = !lngDepartmentID
                Else