利息计算.frm

用友U8财务软件VB源程序, 本版本为2002年版本

        MsgBox "没有需保存的数据！", vbInformation, zjGl_Name
        Exit Sub
    End If
    Screen.MousePointer = vbHourglass
    SaveOneBusiness grid.row
    Screen.MousePointer = vbDefault
End Sub

Public Sub SaveOneBusiness(iRow As Long)
    Dim AccInfo As AccountProperty
    Dim LxdInfo As LXDInfomation
    Dim AccCode As String
    Dim gAcc As String
    Dim pAcc As String
    Dim dRef As Date
    Dim ArType As Variant
    
    With LxdInfo
        .DanID = BillTxtToNumBh(grid.TextMatrix(grid.row, 2))
        .LxdType = ReBillType(grid.TextMatrix(grid.row, 2))
        .isf = IIf(grid.TextMatrix(grid.row, 7) = "应收", 0, 1)
        If .LxdType = UnwDeb_Bill Then
            SaveUnwLxd .DanID, gAcc, pAcc
            .gAccID = gAcc
            .pAccID = pAcc
            AccCode = .pAccID
            AccInfo = AccProperty(.pAccID)
        Else
            If .isf = 0 Then
                .gAccID = grid.TextMatrix(grid.row, 1)
                AccCode = .gAccID
                AccInfo = AccProperty(.gAccID)
            Else
                .pAccID = grid.TextMatrix(grid.row, 1)
                AccCode = .pAccID
                AccInfo = AccProperty(.pAccID)
            End If
        End If
        .FromDay = GetBillSdate(LxdInfo, AccCode)
        .EndDay = FormatDate(edEDate.Text)
        .BillDay = .EndDay + 1
        If grid.TextMatrix(iRow, 6) = "" Then
            .money = CCur(grid.TextMatrix(iRow, 5))
            .cdeLx = 0
        Else
            .money = CCur(grid.TextMatrix(iRow, 5)) + CCur(grid.TextMatrix(iRow, 6))
            .cdeLx = CCur(grid.TextMatrix(iRow, 6))
        End If
        If .LxdType = Cred_Bill Then
            If .FromDay <> CDate(grid.TextMatrix(iRow, 3)) Then GoTo ExitSub1
            BillInfo 0, .DanID, .IntrCode, .CadCode, .ArType
        ElseIf .LxdType = UnwDeb_Bill Then
            If .FromDay <> CDate(grid.TextMatrix(iRow, 3)) Then GoTo ExitSub1
            BillInfo 1, .DanID, .IntrCode, .CadCode
            .CadCode = AccInfo.CadID
        Else
            .IntrCode = AccInfo.IntrID
            .CadCode = AccInfo.CadID
            If grid.TextMatrix(iRow, 2) = "" Then
               
            End If
        End If
        .Freq = GetCurHl(AccInfo.CurrencyName, .EndDay + 1)
    End With
    If LxdInfo.FromDay > LxdInfo.EndDay Then GoTo ExitSub1
    If LxdInfo.LxdType = Save_Bill Then
        Beep
        MsgBox "定期存款进行利息计算时，不允许保存！", vbInformation, zjGl_Name
        Exit Sub
    End If
    If SaveLXD(LxdInfo) Then
      If LxdInfo.LxdType = 0 Then ZeroAccSum AccCode, LxdInfo.EndDay
      MsgBox "保存已完成！", vbInformation, zjGl_Name
    End If
    Exit Sub
    
ExitSub1:
    Beep
    MsgBox "利息单的起讫日期应该连续，利息结果不能保存！", vbInformation, zjGl_Name
    Exit Sub
    
End Sub

Private Function GetBillSdate(LxdInfo As LXDInfomation, cAccCode As String) As Date
   'CuiDong Efficiency-A 2000/06/20 效率优化A OK
   Dim sqlCadAcr As String
   Dim rsCadAcr As New UfRecordset
   Dim Rst As New UfRecordset
   
   Select Case LxdInfo.LxdType
      Case 0
         If LxdInfo.LxdType = Lj_Bill Then
            sqlCadAcr = "SELECT Max(dTo) AS DateTo FROM FD_CadAcr WHERE [cGAccID]='" & cAccCode & "' AND [iDanType]=" & LxdInfo.LxdType
         Else
            sqlCadAcr = "SELECT Max(dTo) AS DateTo FROM FD_CadAcr WHERE [cPAccID]='" & cAccCode & "' AND [iDanType]=" & LxdInfo.LxdType
         End If
         Set rsCadAcr = dbsZJ.OpenRecordset(sqlCadAcr, dbOpenSnapshot)
         If rsCadAcr.EOF Then
LL1:
'            Set rst = dbsZJ.OpenRecordset("FD_AccDef", dbOpenDynaset)  'CuiDong Efficiency-A 2000/06/20 效率优化A
            Set Rst = dbsZJ.OpenRecordset("Select * From FD_AccDef Where cAccID = '" & cAccCode & "'", dbOpenDynaset) 'CuiDong Efficiency-A 2000/06/20 效率优化A
            With Rst
'               .FindFirst "cAccID = '" & cAccCode & "'"                'CuiDong Efficiency-A 2000/06/20 效率优化A
               GetBillSdate = ![dOpenDate]
            End With
         Else
            If IsNull(rsCadAcr![DateTo]) Then
               GoTo LL1
            Else
               GetBillSdate = rsCadAcr![DateTo] + 1
            End If
         End If
      Case 1
         GetBillSdate = SaveBillDay(cAccCode)
      Case 2, 3
         sqlCadAcr = "SELECT Max(dTo) AS DateTo FROM FD_CadAcr WHERE [cDanID]='" & LxdInfo.DanID & "'"
         Set rsCadAcr = dbsZJ.OpenRecordset(sqlCadAcr, dbOpenSnapshot)
         If rsCadAcr.EOF Then
LL2:
'            Set rst = dbsZJ.OpenRecordset(IIf(LxdInfo.LxdType = 2, "FD_Cred", "FD_UnwDeb"), dbOpenDynaset) 'CuiDong Efficiency-A 2000/06/20 效率优化A
            Set Rst = dbsZJ.OpenRecordset("Select * From " & _
                                          IIf(LxdInfo.LxdType = 2, "FD_Cred", "FD_UnwDeb") & _
                                          " Where " & _
                                          IIf(LxdInfo.LxdType = 2, "cCreID", "cUnwID") & _
                                          " = '" & LxdInfo.DanID & "'" _
                                          , dbOpenDynaset)          'CuiDong Efficiency-A 2000/06/20 效率优化A
            
            With Rst
'               If LxdInfo.LxdType = 2 Then                         'CuiDong Efficiency-A 2000/06/20 效率优化A
'                  .FindFirst "cCreID = '" & LxdInfo.DanID & "'"    'CuiDong Efficiency-A 2000/06/20 效率优化A
'               Else                                                'CuiDong Efficiency-A 2000/06/20 效率优化A
'                  .FindFirst "cUnwID = '" & LxdInfo.DanID & "'"    'CuiDong Efficiency-A 2000/06/20 效率优化A
'               End If                                              'CuiDong Efficiency-A 2000/06/20 效率优化A
               If Not (.EOF Or .BOF) Then                           'CuiDong Efficiency-A 2000/06/20 效率优化A
                  GetBillSdate = ![dbill_date]
               End If                                               'CuiDong Efficiency-A 2000/06/20 效率优化A
            End With
         Else
            If IsNull(rsCadAcr![DateTo]) Then
               GoTo LL2
            Else
               GetBillSdate = rsCadAcr![DateTo] + 1
            End If
         End If
   End Select
   
   CloseRS rsCadAcr         'CuiDong Efficiency-A 2000/06/20 效率优化A
   CloseRS Rst              'CuiDong Efficiency-A 2000/06/20 效率优化A
End Function

Private Sub BillInfo(iType As Byte, BillID As String, IntrCode As String, CadCode As String, Optional ArType As Variant)
    'CuiDong Efficiency-A 2000/06/20 效率优化A OK
    Dim rsl As New UfRecordset
    
    If iType = 0 Then   '贷款
'        Set rsl = dbsZJ.OpenRecordset("FD_Cred", dbOpenDynaset)    'CuiDong Efficiency-A 2000/06/20 效率优化A
        Set rsl = dbsZJ.OpenRecordset("Select * From FD_Cred Where cCreID = '" & BillID & "'", dbOpenDynaset) 'CuiDong Efficiency-A 2000/06/20 效率优化A
'        rsl.FindFirst "cCreID = '" & BillID & "'"                  'CuiDong Efficiency-A 2000/06/20 效率优化A
    Else
'        Set rsl = dbsZJ.OpenRecordset("FD_UnwDeb", dbOpenDynaset)  'CuiDong Efficiency-A 2000/06/20 效率优化A
        Set rsl = dbsZJ.OpenRecordset("Select * From FD_UnwDeb Where cUnwID = '" & BillID & "'", dbOpenDynaset) 'CuiDong Efficiency-A 2000/06/20 效率优化A
'        rsl.FindFirst "cUnwID = '" & BillID & "'"                  'CuiDong Efficiency-A 2000/06/20 效率优化A
    End If
'    If Not rsl.NoMatch Then                                        'CuiDong Efficiency-A 2000/06/20 效率优化A
    If Not (rsl.EOF Or rsl.BOF) Then                                'CuiDong Efficiency-A 2000/06/20 效率优化A
        IntrCode = rsl![cintrid]
        On Error Resume Next
        CadCode = rsl![cCadID]
        If Not IsMissing(ArType) Then ArType = rsl![iartyp]
        On Error GoTo 0
    End If
    CloseRS rsl
End Sub

Private Sub SaveUnwLxd(BillID As String, gAcc As String, pAcc As String)
    'CuiDong Efficiency-A 2000/06/20 效率优化A OK
    Dim sql As String
    Dim rsl As New UfRecordset
        
'    Set rsl = dbsZJ.OpenRecordset("FD_UnwDeb", dbOpenDynaset)  'CuiDong Efficiency-A 2000/06/20 效率优化A
    Set rsl = dbsZJ.OpenRecordset("Select * From FD_UnwDeb Where cUnwID = '" & BillID & "'", dbOpenDynaset) 'CuiDong Efficiency-A 2000/06/20 效率优化A
'    rsl.FindFirst "cUnwID = '" & BillID & "'"                  'CuiDong Efficiency-A 2000/06/20 效率优化A
'    If Not rsl.NoMatch Then                                    'CuiDong Efficiency-A 2000/06/20 效率优化A
    If Not (rsl.EOF Or rsl.BOF) Then                            'CuiDong Efficiency-A 2000/06/20 效率优化A
        pAcc = rsl!cGAccID
        gAcc = rsl!cPAccID
    End If
    CloseRS rsl
End Sub

Private Sub tlb_ButtonClick(ByVal Button As ComctlLib.Button)
    Gen_Key Button.key
End Sub

Public Sub Gen_Key(TLB_Key As String)
    Select Case TLB_Key
        Case "Print", "Preview", "Dataout"
            If grid.Rows = 2 And grid.RowHeight(1) = 0 Then
                If TLB_Key = "Dataout" Then
                  MsgBox "没有可输出的数据！", vbInformation, zjGl_Name
                Else
                  MsgBox "没有打印数据!", vbInformation, zjGl_Name
                End If
                Exit Sub
            End If
            zjbPrnViewOut Me, "zjlxjs", TLB_Key, False, "利息一览表"
        Case "save"
            GenSave
        Case "bill"
            grid_DblClick
        Case "lxjs"
            If Command2(0).Enabled Then
'                GenLxjs         'cuidong 2001.10.11
                Command2_Click 0 'cuidong 2001.10.11
            End If
        Case "help"
            SendKeys "{F1}"
        Case "exit"
            Unload Me
  End Select
End Sub

Private Function ReBillRs(iType As LxjsMethod, BType As BillType, rsBill As UfRecordset) As Boolean
    Dim sql As String
        
    Select Case iType
        Case LXJS_M_ACC
            sql = ReAccStr(BType)
        Case LXJS_M_UNIT
            sql = ReUnitStr(BType)
        Case LXJS_M_BILL
            sql = ReBillStr(BType)
    End Select
    Set rsBill = dbsZJ.OpenRecordset(sql, dbOpenSnapshot)
    If Not rsBill.EOF Then ReBillRs = True
End Function

Private Function ReAccStr(BType As BillType) As String
    Dim sql As String
    
    Select Case BType
        Case Cred_Bill
            sql = "select * from FD_Cred " & _
                  "where cAccID = '" & edAccCode & "' " & _
                  "order by cAccID"
        Case Save_Bill
            sql = "select * from FD_Sav " & _
                  "where cAccID = '" & edAccCode & "' " & _
                  "AND [isc]=0 order by cAccID"
        Case UnwDeb_Bill
            sql = "select * from FD_UnwDeb " & _
                  "where cPaccID = '" & edAccCode & "' " & _
                  "order by cPaccID"
        Case Lj_Bill
            sql = "select cAccID from FD_AccDef " & _
                  "where cAccID = '" & edAccCode & "' " & _
                  "and (iType=1 or iDataSrc=1) " & _
                  "order by cAccID"
    End Select
    ReAccStr = sql
End Function

Private Function ReUnitStr(BType As BillType) As String
    Dim sql As String
    Dim cUnitCode As String
    
    cUnitCode = EntNameToCode(edUnitName)
    Select Case BType
        Case Cred_Bill
            sql = " SELECT FD_Cred.*" & _
                  " FROM FD_AccDef INNER JOIN FD_Cred ON FD_AccDef.cAccID = FD_Cred.cAccID" & _
                  " WHERE FD_AccDef.cUnitCode='" & cUnitCode & "'"
        Case Save_Bill
            sql = " SELECT FD_Sav.*" & _
                  " FROM FD_AccDef INNER JOIN FD_Sav ON FD_AccDef.cAccID = FD_Sav.cAccID" & _
                  " WHERE FD_AccDef.cUnitCode='" & cUnitCode & "' " & _
                  " AND FD_Sav.iSc=0"
        Case UnwDeb_Bill
            sql = "SELECT FD_UnwDeb.* " & _
                  "FROM FD_AccDef INNER JOIN FD_UnwDeb ON (FD_AccDef.cAccID = FD_UnwDeb.cPAccID) AND (FD_AccDef.cAccID = FD_UnwDeb.cGAccID) " & _
                  "WHERE FD_AccDef.cUnitCode='" & cUnitCode & "'"
        Case Lj_Bill
            sql = "SELECT DISTINCT FD_AccSum.cAccID " & _
                  "FROM FD_AccDef INNER JOIN FD_AccSum ON FD_AccDef.cAccID = FD_AccSum.cAccID " & _
                  "WHERE FD_AccDef.cUnitCode='" & cUnitCode & "'"
    End Select
    ReUnitStr = sql
End Function

Private Function ReBillStr(BType As BillType) As String
    Dim sql As String
    Dim id1 As String
    Dim id2 As String
    
    id1 = edid(0): id2 = edid(1)
    With cobtype
        Select Case .ListIndex
            Case 1
                id1 = "01" & id1
                id2 = "01" & id2
            Case 2
                id1 = "03" & id1
                id2 = "03" & id2
            Case 3
                id1 = "05" & id1
                id2 = "05" & id2
            Case 4
                id1 = "06" & id1
                id2 = "06" & id2
            Case 5
                id1 = "07" & id1
                id2 = "07" & id2
        End Select
    End With
    Select Case BType
        Case Cred_Bill
            sql = "select * from FD_Cred " & _
                  "where cCreID>='" & id1 & "' " & _
                  "and cCreID<='" & id2 & "' " & _
                  "order by cAccID"
        Case Save_Bill
            sql = "select * from FD_Sav " & _
                  "where cSavID>='" & id1 & "' " & _
                  "and cSavID<='" & id2 & "' " & _
                  "and isc=0 " & _
                  "order by cAccID"
        Case UnwDeb_Bill
            sql = "select * from FD_UnwDeb " _
                  & "where cUnwID>='" & id1 & "' " _
                  & "and cUnwID<='" & id2 & "' " _
                  & "order by cGAccID"
    End Select
    ReBillStr = sql
End Function

Private Function ReBillType(bh As String) As String
    Dim cDanType As String
    
    If bh <> "" Then
        cDanType = BillNameToCode(left(bh, InStr(1, bh, "-") - 1))
        Select Case cDanType
          Case "05", "06"
            ReBillType = 2
          Case "07"
            ReBillType = 3
          Case "01", "03"
            ReBillType = 1
        End Select
    Else
        ReBillType = 0
    End If
End Function