日记帐.frm

用友u8财务源码,用visual basic开发

      rsTable.MoveNext
   Loop

End Sub
'*******************************************************************
'*函数说明:对定期存款单进行利息计算                                  *
'*参    数:                                                        *
'*返回值  :                                                        *
'*******************************************************************
Private Sub EstimateCadSav()
   Dim sqlTable As String
   Dim sqlCad As String
   Dim rsTable As New UfRecordset
   Dim rsCad As New UfRecordset
   Dim dYmd As Date
   
   sqlTable = "SELECT * FROM FD_Sav WHERE NOT bsettle AND isc=0"
   Set rsTable = dbsZJ.OpenRecordset(sqlTable, dbOpenDynaset)
   If Not rsTable.EOF Then
      rsTable.MoveLast
      Me.ProgressBar1.Max = rsTable.RecordCount
      rsTable.MoveFirst
   End If
   While Not rsTable.EOF
      ChangeStatus Right(rsTable!cSavID, 8), 1
      dYmd = GetDqDate(rsTable!iMonth, rsTable!dbill_date)
      If dYmd - 1 <= dDate Then
         sqlCad = "SELECT * FROM FD_CadAcr WHERE cDanID='" & rsTable!cSavID & _
               "' AND dTo<='" & FormatDate(dYmd) & "'"
         Set rsCad = dbsZJ.OpenRecordset(sqlCad, dbOpenDynaset)
         If rsCad.EOF Then
            ' 计息
            dq_lx rsTable!cAccID, dYmd, True
         End If
      End If
      rsTable.MoveNext
   Wend
   
End Sub

'cuidong YT.A 2001.10.21
'函数说明:对 定期存款单 预提数据 进行利息计算
Private Sub EstimateYtCadSav()
   Dim sqlAccDef  As String
   Dim sqlAccSum  As String
   Dim sqlCadSets As String
   Dim RsAccDef   As New UfRecordset
   Dim rsAccSum   As New UfRecordset
   Dim RsCadSets  As New UfRecordset
   Dim Rs As UfRecordset
   Dim dTemp      As Date
   Dim dOpenDate  As Date
   
   
   Dim sqlTable As String
   Dim sqlCad As String
   Dim rsTable As New UfRecordset
   Dim rsCad As New UfRecordset
   Dim dYmd As Date
   
   Dim dStartDate As Date
   Dim sEndDate As String
   
   '包括已销户的
   sqlTable = "SELECT FD_AccDef.cAccID, FD_AccDef.iYt, FD_AccDef.cYtID, FD_Sav.cSavID, FD_Sav.iMonth, FD_Sav.dBill_Date, FD_Sav.bSettle FROM FD_Sav, FD_AccDef WHERE FD_Sav.cAccID = FD_AccDef.cAccID And FD_Sav.isc=0 And (Not FD_AccDef.iYt = 0) And (Not FD_AccDef.cYtID Is Null) And (Not cBookCode Is Null) "
   Set rsTable = dbsZJ.OpenRecordset(sqlTable, dbOpenDynaset)
   If Not rsTable.EOF Then
      rsTable.MoveLast
      Me.ProgressBar1.Max = rsTable.RecordCount
      rsTable.MoveFirst
   End If
   
   While Not rsTable.EOF
      If (Not IIf(IsNull(rsTable!iYt), 0, rsTable!iYt) = 0) And (Not IsNull(rsTable!cYtID)) Then
         ChangeStatus rsTable!cAccID, 1
         dStartDate = rsTable!dbill_date '首次预提计息的起始日期
         sEndDate = vbNullString
         If Not IsNull(rsTable!bSettle) Then
            If Not rsTable!bSettle = 0 Then
               '已经结清
               Set Rs = dbsZJ.OpenRecordset("Select Max(dBill_Date) As dBill_Date From FD_Fetch Where cAccID = '" & rsTable!cAccID & "'")
               If Not IsNull(Rs!dbill_date) Then
                  sEndDate = Format(Rs!dbill_date, "YYYY-MM-DD")
               End If
               Rs.oClose
                
            End If
         End If
         '---- 取出结息日信息
         sqlCadSets = "SELECT dClosDate FROM FD_CadSets WHERE cCadID='" & rsTable!cYtID & "' ORDER BY dClosDate"
         Set RsCadSets = dbsZJ.OpenRecordset(sqlCadSets, dbOpenSnapshot)
         Do While Not RsCadSets.EOF
            dTemp = RsCadSets!dClosDate
            If dDate < dTemp Then Exit Do
            If Not sEndDate = vbNullString Then
               '预提日（结息日）当天或之前若 有实际利息单发生，则不生成预提利息单
               If CDate(sEndDate) <= dTemp Then Exit Do
            End If
'            If dTemp > RetEndDay(rsTable!dbill_date, rsTable!iMonth) - 1 Then
'               Exit Do '最后一个预提日 - 定期取款日 之间的利息不计算，否则请删去此行。
'               dTemp = RetEndDay(rsTable!dbill_date, rsTable!iMonth) - 1
'            End If
            
            If dTemp > rsTable!dbill_date Then
               sqlAccSum = "SELECT * FROM FD_YtCadAcr WHERE cGAccID='" & rsTable!cAccID & _
                     "' AND dBill_date='" & FormatDate(dTemp) & "'"
               Set rsAccSum = dbsZJ.OpenRecordset(sqlAccSum, dbOpenDynaset)
               If rsAccSum.EOF Then
                  '计算预提日（结息日）利息
                  DQ_YtLx rsTable!cAccID, dStartDate, dTemp, True
               End If
               rsAccSum.oClose
               dStartDate = RsCadSets!dClosDate + 1 '下次预提计息的起始日期
            End If
            
            RsCadSets.MoveNext
         Loop
      End If
      rsTable.MoveNext
   Wend
'
'   While Not rsTable.EOF
'      ChangeStatus Right(rsTable!cSavID, 8), 1
'      dYmd = GetDqDate(rsTable!iMonth, rsTable!dbill_date)
'      If dYmd - 1 <= dDate Then
'         sqlCad = "SELECT * FROM FD_CadAcr WHERE cDanID='" & rsTable!cSavID & _
'               "' AND dTo<='" & FormatDate(dYmd) & "'"
'         Set rsCad = dbsZJ.OpenRecordset(sqlCad, dbOpenDynaset)
'         If rsCad.EOF Then
'            ' 计息
'            dq_lx rsTable!cAccID, dYmd, True
'         End If
'      End If
'      rsTable.MoveNext
'   Wend
      
End Sub

Private Function GetDqDate(lngMonth As Integer, dPre As Date) As Date
   Dim iYear   As Long
   Dim iMonth  As Long
   Dim iDay    As Long
   
   iMonth = (Month(dPre) + lngMonth) Mod 12
   If iMonth = 0 Then iMonth = 12
   iYear = Year(dPre) + (Month(dPre) + lngMonth - 1) \ 12
   iDay = Day(dPre)
   
   On Error GoTo lblErr
   GetDqDate = CDate(iYear & "-" & iMonth & "-" & iDay)
   Exit Function

lblErr:
   iDay = iDay - 1
   Resume

End Function

Private Sub RezeroStatus(strLabel0 As String, strLabel1 As String, Optional lngMax As Variant)
   With Me
      .ProgressBar1.Value = 0
      If Not IsMissing(lngMax) Then .ProgressBar1.Max = lngMax
      .Label1(4) = strLabel0
      .Label1(1) = strLabel1
      .Label1(0).Left = .Label1(1).Left + .Label1(1).Width + 100
      .Label1(0) = ""
      .Refresh
   End With
End Sub

Private Sub ChangeStatus(strLabel2 As String, lngUnit As Long, Optional strLabel1 As Variant)
   With Me
      On Error Resume Next
      .ProgressBar1.Value = .ProgressBar1.Value + lngUnit
      If Not IsMissing(strLabel1) Then .Label1(1) = strLabel1
      .Label1(0) = strLabel2
      .Refresh
   End With
End Sub

'资金账户的定额处理
Private Sub ZjDeTreat()
   Dim rsAccSum   As New UfRecordset
   Dim RsAccDef   As New UfRecordset
   Dim sqlAccSum  As String
   Dim sqlAccDef  As String
   Dim vDe        As Variant
   Dim cDe        As Currency
   Dim cMh_c      As Currency
   
   On Error Resume Next
   sqlAccDef = "SELECT cAccID FROM FD_AccDef WHERE iDataSrc=0 AND itype=1"
   Set RsAccDef = dbsZJ.OpenRecordset(sqlAccDef, dbOpenSnapshot)
   If Not RsAccDef.EOF Then
      RsAccDef.MoveLast
      RezeroStatus "正在进行定额处理...", "资金账户：", RsAccDef.RecordCount
      RsAccDef.MoveFirst
   End If
   While Not RsAccDef.EOF
      ChangeStatus RsAccDef!cAccID, 1, "资金账户："
      sqlAccSum = "SELECT * FROM FD_AccSum WHERE cAccID='" & RsAccDef!cAccID & _
                  "' ORDER BY dbill_date"
      Set rsAccSum = dbsZJ.OpenRecordset(sqlAccSum, dbOpenDynaset)
      DeResult RsAccDef!cAccID
      cMh_c = 0
      With rsAccSum
         While Not .EOF
            vDe = GetDe(!dbill_date)
            If Not IsEmpty(vDe) Then
               cDe = !Mb - CCur(vDe)
               .Edit
               !Mcde = IIf(cDe > 0, cDe, 0)
               !Mcdeh = cMh_c + !Mcde - !Mcdeh_Cad
               cMh_c = IIf(IsNull(!Mcdeh), 0, !Mcdeh)
               .Update
            Else
               .Edit
               !Mcdeh = cMh_c - !Mcdeh_Cad
               .Update
            End If
            .MoveNext
         Wend
      End With
      RsAccDef.MoveNext
   Wend
   CloseRS RsAccDef
End Sub

'*******************************************************************
'*函数说明:对总账表进行初始化                                       *
'*参    数:                                                        *
'*返回值  :                                                        *
'*******************************************************************
Private Sub InitFD_Accsum()
   Dim rsAccSum As New UfRecordset
   Dim RsAccDef As New UfRecordset
   Dim sqlAccSum As String
   Dim sqlAccDef As String
   Dim strQryChg As String
   
   On Error GoTo lblErr
   dbsZJ.BeginTrans
   ' 资金账户
   sqlAccDef = "SELECT cAccID, mb, mh, dOpenDate FROM FD_AccDef WHERE iDataSrc=0 AND itype=1"
   Set RsAccDef = dbsZJ.OpenRecordset(sqlAccDef, dbOpenSnapshot)
   If Not RsAccDef.EOF Then
      RsAccDef.MoveLast
      RezeroStatus "正在进行初始化...", "资金账户：", RsAccDef.RecordCount
      RsAccDef.MoveFirst
   End If
   While Not RsAccDef.EOF
      ChangeStatus RsAccDef!cAccID, 1, "资金账户："
      sqlAccSum = "SELECT * FROM FD_AccSum WHERE cAccID='" & RsAccDef!cAccID & _
                  "' ORDER BY dbill_date"
      Set rsAccSum = dbsZJ.OpenRecordset(sqlAccSum, dbOpenDynaset)
      With rsAccSum
         If .EOF Then
            .AddNew
            !cAccID = RsAccDef!cAccID
            !dbill_date = IIf(RsAccDef!dOpenDate < ZjAccInfo.zjStartdate, ZjAccInfo.zjStartdate, RsAccDef!dOpenDate) - 1 '----zcl change
            !Mb = RsAccDef!Mb
            !Mh = RsAccDef!Mh
            .Update
         Else
            '期初改变
            If RsAccDef!Mb <> !Mb Or RsAccDef!Mh <> !Mh Then
               strQryChg = "UPDATE FD_AccSum SET mb = mb + " & (RsAccDef!Mb - !Mb) & _
                  ", mh = mh + " & (RsAccDef!Mh - !Mh) & " + " & _
                  Format((RsAccDef!Mb - !Mb), "#0.00") & " * (DateDiff(Day, '" & FormatDate(RsAccDef!dOpenDate) & "', dbill_date) + 1)" & _
                  "WHERE cAccID = '" & RsAccDef!cAccID & "'"
               dbsZJ.Execute strQryChg
            End If
         End If
      End With
      
      ' 将 FD_AccSum(总账表) 中每一账户追补到今日
      TraceToNow RsAccDef!cAccID
      RsAccDef.MoveNext
   Wend
   dbsZJ.CommitTrans
   On Error GoTo 0
   
   ' 外部账户
   sqlAccDef = "SELECT cAccID, dOpenDate FROM FD_AccDef WHERE iDataSrc=1"
   Set RsAccDef = dbsZJ.OpenRecordset(sqlAccDef, dbOpenSnapshot)
   If Not RsAccDef.EOF Then
      RsAccDef.MoveLast
      RezeroStatus "正在进行初始化...", "外部账户：", RsAccDef.RecordCount
      RsAccDef.MoveFirst
      
      Set rsSumWb = dbsZJ.OpenRecordset("FD_AccSum", dbOpenDynaset)
   End If
   
   While Not RsAccDef.EOF
      ChangeStatus RsAccDef!cAccID, 1, "外部账户："
      
      Dim dBillDate  As Date
      Dim rsX        As New UfRecordset
      Dim sqlX       As String
      
      sqlX = "SELECT Max(dbill_date) AS MaxDate FROM FD_AccSum WHERE cAccID = '" & RsAccDef!cAccID & "'"
      Set rsX = dbsZJ.OpenRecordset(sqlX, dbOpenSnapshot)
      If IsNull(rsX!MaxDate) Then
         dBillDate = IIf(RsAccDef!dOpenDate < ZjAccInfo.zjStartdate, ZjAccInfo.zjStartdate, RsAccDef!dOpenDate) - 1 '----zcl change
      Else
         dBillDate = rsX!MaxDate + 1
      End If
      
      '1
      TraceWb RsAccDef!cAccID, dBillDate
      '2
      DoWb RsAccDef!cAccID, IIf(RsAccDef!dOpenDate < ZjAccInfo.zjStartdate, ZjAccInfo.zjStartdate, RsAccDef!dOpenDate), dDate '----zcl change
      '3
      SucWb RsAccDef!cAccID
      
      RsAccDef.MoveNext
   Wend
   Exit Sub
   
lblErr: