frmaccountinterest.frm

金算盘软件代码

    Dim lngCnt As Long
    Dim strSql As String
    Dim recAcc As rdoResultset
    
    If fraWizard(1).Tag <> "已设置" Then
        
        strSql = "SELECT lngAccountID,lngDebitAccountID,lngCreditAccountID, DECODE(lngDebitAccountID+lngDebitAccountID,0,'','√') As 选择, " _
                & "strAccountCode || ' ' || strAccountName As 本金科目, " _
                & "'' As 借方科目,'' As 贷方科目,intDirection " _
                & "FROM Account  " _
                & "WHERE blnIsCalcInterest=1 AND blnIsDetail=1 AND blnIsInActive=0 " _
                & "ORDER BY strAccountCode"
        
        Set recAcc = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        Set datAccount.Resultset = recAcc
        Set mclsGrid = New Grid
        Set mclsGrid.Grid = msgAcc
        
        mclsGrid.ColOfs = 4
        mclsGrid.SetupStyle
        msgAcc.ColWidth(0) = 0
        msgAcc.ColWidth(1) = 0
        msgAcc.ColWidth(2) = 0
        msgAcc.ColWidth(3) = 450
        msgAcc.ColWidth(4) = 1830
        msgAcc.ColWidth(5) = 1800
        msgAcc.ColWidth(6) = 1800
        msgAcc.ColWidth(7) = 0
        Set mclsGrid.EditText = ltxtAccount
        mclsGrid.SetEditText "借方科目", ""
        mclsGrid.SetEditText "贷方科目", ""
        
        '科目参照
        RefreshAccount
        lngID = GetSet(1, "科目计息", "借方科目", 0)
        If lngID > 0 Then
            ltxtDebitAccount.SeekId lngID
        End If
        lngID = GetSet(1, "科目计息", "贷方科目", 0)
        If lngID > 0 Then
            ltxtCreditAccount.SeekId lngID
        End If
        
        With msgAcc
            .Redraw = False
            For lngCnt = 1 To .Rows - 1
                If .TextMatrix(lngCnt, 1) > 0 Then
                    ltxtAccount.SeekId .TextMatrix(lngCnt, 1)
                    .TextMatrix(lngCnt, 5) = ltxtAccount.Text
                End If
                If .TextMatrix(lngCnt, 2) > 0 Then
                    ltxtAccount.SeekId .TextMatrix(lngCnt, 2)
                    .TextMatrix(lngCnt, 6) = ltxtAccount.Text
                End If
            Next lngCnt
            .Redraw = True
        End With
        fraWizard(1).Tag = "已设置"
    End If
    fraWizard(3).Tag = ""
End Function

'第三步：凭证选项初始
Private Function InitOption()
    Dim lngID As Long
    If fraWizard(2).Tag <> "已设置" Then
        
        fraWizard(2).Tag = "已设置"

        '凭证模板参照
        RefreshTemplate
        lngID = CLng(GetSet(1, "汇兑损益", "凭证摸板", 0))
        If lngID > 0 Then lstxtTemplate.SeekId lngID
    
        '凭证类型参照
        RefreshVoucherType
        lngID = CLng(GetSet(1, "汇兑损益", "凭证类型", 0))
        If lngID > 0 Then lstxtType.SeekId lngID
    End If
End Function

'第四步：凭证预缆初始
Private Function InitResult()
    Dim lngCnt As Long, lngCntDetail As Long, lngCntOrder As Long
    Dim strResult As String, strDetail As String, strAmount As String
    Dim strSql As String
    Dim recAccount As rdoResultset
    Dim lngLen As Long, lngSpace As Long
    Dim errNo As Long
    
'    On Error GoTo ErrHandle
    
    If fraWizard(3).Tag <> "已设置" Then
        
        fraWizard(3).Tag = "已设置"
        txtResult.Text = ""
        
        msgInterest.WordWrap = True
        msgInterest.Cols = 15
        msgInterest.Rows = 2
        msgInterest.RowHeight(1) = 250
        msgInterest.TextMatrix(1, 0) = 0
        msgInterest.TextMatrix(1, 1) = 0
        msgInterest.TextMatrix(1, 2) = 0
        msgInterest.TextMatrix(1, 3) = 0
        msgInterest.TextMatrix(1, 4) = 0
        msgInterest.TextMatrix(1, 5) = 0
        msgInterest.TextMatrix(1, 6) = 0
        msgInterest.TextMatrix(1, 7) = 0
        msgInterest.TextMatrix(1, 8) = 0
        msgInterest.TextMatrix(1, 9) = 0
        msgInterest.TextMatrix(1, 10) = 0
        msgInterest.TextMatrix(1, 11) = 0
        msgInterest.TextMatrix(1, 12) = ""
        msgInterest.TextMatrix(1, 13) = 0
        msgInterest.TextMatrix(1, 14) = 0
        
        msgInterest.ColWidth(0) = 0     '科目
        msgInterest.ColWidth(1) = 0     '单位
        msgInterest.ColWidth(2) = 0     '部门
        msgInterest.ColWidth(3) = 0     '职员
        msgInterest.ColWidth(4) = 0     '统计
        msgInterest.ColWidth(5) = 0     '项目
        msgInterest.ColWidth(6) = 0     '币种
        msgInterest.ColWidth(7) = 0     '积数
        msgInterest.ColWidth(8) = 0     '借方科目
        msgInterest.ColWidth(9) = 0     '借方属性
        msgInterest.ColWidth(10) = 0     '贷方科目
        msgInterest.ColWidth(11) = 0     '贷方属性
        
        msgInterest.ColWidth(12) = 2900     '科目名称
        msgInterest.ColWidth(13) = 1200     '积数
        msgInterest.ColWidth(14) = 1200     '利息
        msgInterest.TextMatrix(0, 12) = "科目名称"
        msgInterest.TextMatrix(0, 13) = "积数"
        msgInterest.TextMatrix(0, 14) = "利息"
        msgInterest.ColAlignment(12) = 1
        msgInterest.ColAlignment(13) = 8
        msgInterest.ColAlignment(14) = 8
        
        '摘要参照
        If Trim$(lstxtRemark.Text) = "" Then
            strResult = "科目计息"
        Else
            strResult = lstxtRemark.Text
        End If
        RefreshRemark
        lstxtRemark.Text = strResult
        
        '生成凭证
        GenInterestVoucher
        
        If Not VoucherData(0).Used Then Exit Function
            
        strResult = ""
        lngLen = 54
        For lngCnt = 0 To UBound(VoucherData)
            With VoucherData(lngCnt)
                For lngCntOrder = 0 To UBound(.Detail)
                    If .Detail(UBound(.Detail)).Direction = adCredit Then
                        lngCntDetail = lngCntOrder
                    Else
                        If lngCntOrder = 0 Then
                            lngCntDetail = UBound(.Detail)
                        Else
                            lngCntDetail = lngCntOrder - 1
                        End If
                    End If
                    If .Detail(lngCntDetail).Direction = adDebit Then
                        strDetail = "借："
                    Else
                        strDetail = "贷："
                    End If
                    strSql = "SELECT strAccountCode,strAccountName FROM Account " _
                        & "WHERE lngAccountID=" & .Detail(lngCntDetail).AccountID
                    Set recAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                    If Not recAccount.EOF Then
                        strDetail = strDetail & recAccount!strAccountCode & " " _
                            & Trim(recAccount!strAccountName)
                            If .Detail(lngCntDetail).CustomerID > 0 Then
                                strResult = strResult & strDetail & Chr(13) & Chr(10)
                                strDetail = Space(4) & "— " & CustomerName(.Detail(lngCntDetail).CustomerID)
                            End If
                            If .Detail(lngCntDetail).DepartmentID > 0 Then
                                strResult = strResult & strDetail & Chr(13) & Chr(10)
                                strDetail = Space(4) & "— " & DepartmentName(.Detail(lngCntDetail).DepartmentID)
                            End If
                            If .Detail(lngCntDetail).EmployeeID > 0 Then
                                strResult = strResult & strDetail & Chr(13) & Chr(10)
                                strDetail = Space(4) & "— " & EmployeeName(.Detail(lngCntDetail).EmployeeID)
                            End If
'                            If .Detail(lngCntDetail).JobID > 0 Then
'                                strDetail = strDetail & "/" & JobName(.Detail(lngCntDetail).JobID)
'                            End If
                            If .Detail(lngCntDetail).ClassID1 > 0 Then
                                strResult = strResult & strDetail & Chr(13) & Chr(10)
                                strDetail = Space(4) & "— " & Class1Name(.Detail(lngCntDetail).ClassID1)
                            End If
                            If .Detail(lngCntDetail).ClassID2 > 0 Then
                                strResult = strResult & strDetail & Chr(13) & Chr(10)
                                strDetail = Space(4) & "— " & Class2Name(.Detail(lngCntDetail).ClassID2)
                            End If
                            If .Detail(lngCntDetail).CurrencyID > 0 And .Detail(lngCntDetail).CurrencyID <> gclsBase.NaturalCurId Then
                                strResult = strResult & strDetail & Chr(13) & Chr(10)
                                strDetail = Space(4) & "— " & CurrencyName(.Detail(lngCntDetail).CurrencyID)
                            End If
                    End If
                    lngSpace = lngLen - StrLen(strDetail) - 14
                    If lngSpace < 0 Then lngSpace = 0
                    strDetail = strDetail & Space(lngSpace)
                    strAmount = Format(.Detail(lngCntDetail).Amount, "#0.00")
                    lngSpace = 14 - StrLen(strAmount)
                    If lngSpace < 0 Then lngSpace = 0
                    strDetail = strDetail & Space(lngSpace) & strAmount
                    strResult = strResult & strDetail & Chr(13) & Chr(10)
                Next lngCntOrder
            End With
            strResult = strResult & "───────────────────────────" & Chr(13) & Chr(10)
        Next lngCnt
        txtResult.Text = strResult
    End If
    Exit Function
    
ErrHandle:
    errNo = Errors.ErrorsDeal(True, Me)
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case edtCanNotKnown
        ShowMsg hwnd, "程序出错：" & Err.Description, vbOKOnly + vbCritical, Caption
    End Select
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  向导步骤合法检查
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'第一步，期末汇率
Private Function ValidRate(Msg As String, Optional objHwnd As Long) As Boolean
    Dim lngRow As Long
    On Error Resume Next
    
    ValidRate = True
    
    If ValidRate Then
        If Format(cldBeginDate.Text, "yyyy-mm-dd") < Format(gclsBase.BeginDate, "yyyy-mm-dd") Then
            Msg = "上次计息日期不能小于帐套起用日期！"
            ValidRate = False
            objHwnd = cldBeginDate.hwnd
        End If
    End If
    
    If ValidRate Then
        If Format(cldEndDate.Text, "yyyy-mm-dd") <= Format(cldBeginDate.Text, "yyyy-mm-dd") Then
            Msg = "本次计息日期必须大于上次计息日期！"
            ValidRate = False
            objHwnd = cldEndDate.hwnd
        End If
    End If
    
    If ValidRate Then
        If C2Dbl(txtRate.Text) <= 0 Then
            Msg = "计算利率必须大于0！"
            ValidRate = False
            objHwnd = txtRate.hwnd
        End If
    End If
    
    If ValidRate Then
        SaveSet 1, "科目计息", "开始日期", cldBeginDate.Text, True, "String"
        SaveSet 1, "科目计息", "利率", IIf(C2Dbl(txtRate.Text) = 0, "0", txtRate.Text), True, "Double"
    End If
End Function

'第二步，损益科目
Private Function ValidAccount(Msg As String) As Boolean
    Dim strSql As String
    Dim lngCnt As Long
    Dim lngChoice As Long
    
    On Error Resume Next
    ValidAccount = True
    
    If ValidAccount Then
        For lngCnt = 1 To msgAcc.Rows - 1
            If msgAcc.TextMatrix(lngCnt, 3) = "√" Then
                If C2lng(msgAcc.TextMatrix(lngCnt, 1)) = 0 Or C2lng(msgAcc.TextMatrix(lngCnt, 2)) = 0 Then
                    Msg = "必须输入" & msgAcc.TextMatrix(lngCnt, 4) & "的借贷方科目！"
                    ValidAccount = False
                    Exit For
                ElseIf C2lng(msgAcc.TextMatrix(lngCnt, 1)) = C2lng(msgAcc.TextMatrix(lngCnt, 2)) Then
                    Msg = msgAcc.TextMatrix(lngCnt, 4) & "的借贷方科目不能是同一科目！"
                    ValidAccount = False
                    Exit For
                ElseIf Not ChoiceOne(lngCnt, Msg, True) Then
                    ValidAccount = False
                    Exit For
                Else
                    lngChoice = lngChoice + 1
                End If
            End If
        Next lngCnt
    End If

    If ValidAccount Then
        If lngChoice = 0 And msgAcc.Rows > 1 Then
            Msg = "请选择需要计算利息的科目！"
            ValidAccount = False
        End If
    End If
End Function

'第三步，凭证选项
Private Function ValidOption(Msg As String) As Boolean
    Dim strSql As String
    Dim recTm