+-+

VB财务软件系统下载源代码提供自由下载使用学习

   End Select

End Sub

Private Sub Form_Load()
   Me.Icon = LoadResPicture(109, vbResIcon)
   initGrid
   RptTlb Toolbar1, ImageList1
   Picture1.Width = ZjAccInfo.zjPictWidth
   Picture1.Picture = LoadPicture(ZjAccInfo.zjRepPath & "BookBack.BMP")
   Me.Show
   DoEvents
   mCale
End Sub

'********************************************************************
'*函数说明: 填充 Grid                                                 *
'*参    数:                                                          *
'*                                                                   *
'*返回值  :                                                          *
'*********************************************************************
Public Sub mCale()
    '----设置互斥
    m_bExclude = True
   
   Dim rsItem As New UfRecordset
   Dim rsCale As New UfRecordset
   Dim sqlItem As String
   Dim sqlCale As String
   Dim strTotal As String
   Dim rsProperty As New UfRecordset
   Dim bProperty As Boolean
   Dim sqlQc As String
   Dim rsQc As New UfRecordset
   Dim mQc As Double
   Dim cExch As String
   Dim dblHl As Variant
   Dim dblA As Variant
   Dim dblB As Variant
   Dim dblC As Variant
   Dim dblD As Variant
   Dim iTotal As Boolean
   Dim todayMb As Double
   Dim preMb As Double
   Dim CurMd As Double
   Dim curMc As Double
   Dim mInTemp As Long
   Dim mOut As Long
   Dim iX As Integer
   Dim i As Long
   
   sqlItem = "SELECT * FROM FD_Items WHERE iitems_id=4 ORDER BY citem_id"
   Set rsItem = dbsZJ.OpenRecordset(sqlItem, dbOpenSnapshot)
   StatusBar1.Visible = True
   ProBar1.Visible = True
   Form_Resize
   If Not rsItem.EOF Then
      rsItem.MoveLast
      ProBar1.Max = rsItem.RecordCount
      ProBar1.Value = 0
      ProBar1.Min = 0
      rsItem.MoveFirst
      DoUnload True
   End If
   With rsItem
      While Not .EOF
         ChangeStatus "项目：" & !cItem_Name, 1
         preGrade = !iGrade
         If !bend Then   ' 末级，计算
            If !bSource Then   '从科目取数
               cExch = ZjAccInfo.zjStandExch
               dblHl = 1
               Cal_KhdtKm !iItem_id
               With KhdtInfo
                  todayMb = .todayMb
                  CurMd = .CurMd
                  curMc = .curMc
                  preMb = .preMb
                  mInTemp = .mInTemp
                  mOut = .mOut
               End With
               dblA = todayMb
               dblB = curMc
               dblC = CurMd
               dblD = preMb
               For i = 1 To preGrade
                  preDayYe(i) = preDayYe(i) + preMb
                  toDaySr(i) = toDaySr(i) + curMc
                  toDayZc(i) = toDayZc(i) + CurMd
                  toDayYe(i) = toDayYe(i) + todayMb
                  toDayBsr(i) = toDayBsr(i) + mInTemp
                  toDayBzc(i) = toDayBzc(i) + mOut
               Next i
            Else                 '从账户取数
               '判断此项目下包含内部账户或外部账户或都有
               iX = GetZhStyle(!iItem_id)
               dblA = 0: dblB = 0: dblC = 0: dblD = 0
               
               '取出币别和汇率
               cExch = GetExch(!iItem_id)
               If cExch <> "" Then
                  dblHl = GetCurHl(cExch, zjLogInfo.curDate)
                  If dblHl = 0 Then
                     MsgBox "币别" & cExch & "未设置汇率！", vbInformation, zjGl_Name
                     dblHl = ""
                  End If
               Else
                  dblHl = ""
               End If
               
               '第一步：从资金账户取数
               If iX = 1 Or iX = 3 Then
                  Cal_Khdt !iItem_id
                  With KhdtInfo
                     todayMb = .todayMb
                     CurMd = .CurMd
                     curMc = .curMc
                     preMb = .preMb
                     mInTemp = .mInTemp
                     mOut = .mOut
                  End With
                  If dblHl = "" Then
                     dblA = "": dblB = "": dblC = "": dblD = "":
                  Else
                     dblA = todayMb / dblHl
                     dblB = CurMd / dblHl
                     dblC = curMc / dblHl
                     dblD = preMb / dblHl
                  End If
                  For i = 1 To preGrade
                     preDayYe(i) = preDayYe(i) + preMb
                     toDaySr(i) = toDaySr(i) + CurMd
                     toDayZc(i) = toDayZc(i) + curMc
                     toDayYe(i) = toDayYe(i) + todayMb
                     toDayBsr(i) = toDayBsr(i) + mInTemp
                     toDayBzc(i) = toDayBzc(i) + mOut
                  Next i
               End If
               If iX = 2 Or iX = 3 Then
                  '第二步：从账务账户取数
                  Cal_KhdtZh !iItem_id
                  With KhdtInfo
                     todayMb = .todayMb
                     CurMd = .CurMd
                     curMc = .curMc
                     preMb = .preMb
                     mInTemp = .mInTemp
                     mOut = .mOut
                  End With
                  If dblHl = "" Then
                     dblA = "": dblB = "": dblC = "": dblD = "":
                  Else
                     dblA = dblA + todayMb / dblHl
                     dblB = dblB + CurMd / dblHl
                     dblC = dblC + curMc / dblHl
                     dblD = dblD + preMb / dblHl
                  End If
                  
                  For i = 1 To preGrade
                     preDayYe(i) = preDayYe(i) + preMb
                     toDaySr(i) = toDaySr(i) + CurMd
                     toDayZc(i) = toDayZc(i) + curMc
                     toDayYe(i) = toDayYe(i) + todayMb
                     toDayBsr(i) = toDayBsr(i) + mInTemp
                     toDayBzc(i) = toDayBzc(i) + mOut
                  Next i
               End If
            End If
            If dblB = "" Then dblB = 0
            If dblC = "" Then dblC = 0
            UfGridADO1.AddItem Space((preGrade - 1) * 3) & !cItem_Name & vbTab & _
               cExch & vbTab & dblHl & vbTab & _
               FormatCur(dblD) & vbTab & _
               FormatCur(preDayYe(preGrade)) & vbTab & _
               IIf(dblB = 0, "", FormatCur(dblB)) & vbTab & _
               IIf(toDaySr(preGrade) = 0, "", FormatCur(toDaySr(preGrade))) & vbTab & _
               IIf(toDayBsr(preGrade) = 0, "", toDayBsr(preGrade)) & vbTab & _
               IIf(dblC = 0, "", FormatCur(dblC)) & vbTab & _
               IIf(toDayZc(preGrade) = 0, "", FormatCur(toDayZc(preGrade))) & vbTab & _
               IIf(toDayBzc(preGrade) = 0, "", toDayBzc(preGrade)) & vbTab & _
               FormatCur(dblA) & vbTab & _
               FormatCur(toDayYe(preGrade))
            DoEvents
            If preGrade <> 1 Then MakeZero preGrade
         Else              ' 非末级
            
            UfGridADO1.AddItem Space((preGrade - 1) * 3) & !cItem_Name
         End If
         .MoveNext
         If .EOF Then
            iTotal = True
         Else
            If !iGrade = 1 Then iTotal = True
         End If
         If iTotal Then
            For i = preGrade - 1 To 2 Step -1
               strTotal = "小计:"
               
               With UfGridADO1
                  .AddItem Space(i * 3) & strTotal & vbTab & "" & vbTab & "" & vbTab & "" & _
                     vbTab & FormatCur(preDayYe(i)) & vbTab & "" & vbTab & IIf(toDaySr(i) = 0, "", FormatCur(toDaySr(i))) & vbTab & _
                     IIf(toDayBsr(i) = 0, "", toDayBsr(i)) & vbTab & "" & vbTab & IIf(toDayZc(i) = 0, "", FormatCur(toDayZc(i))) & vbTab & IIf(toDayBzc(i) = 0, "", toDayBzc(i)) & _
                     vbTab & "" & vbTab & FormatCur(toDayYe(i))
               End With
               MakeZero i
            Next i
            strTotal = "合计:"
            
            With UfGridADO1
               .AddItem Space(3) & strTotal & vbTab & "" & vbTab & "" & vbTab & "" & _
                  vbTab & FormatCur(preDayYe(1)) & vbTab & "" & vbTab & IIf(toDaySr(1) = 0, "", FormatCur(toDaySr(1))) & vbTab & _
                  IIf(toDayBsr(1) = 0, "", toDayBsr(1)) & vbTab & "" & vbTab & IIf(toDayZc(1) = 0, "", FormatCur(toDayZc(1))) & vbTab & IIf(toDayBzc(1) = 0, "", toDayBzc(1)) & _
                  vbTab & "" & vbTab & FormatCur(toDayYe(1))
            End With
            MakeZero 1
            iTotal = False
         Else
            If !iGrade < preGrade Then
               
               strTotal = "小计:"
               With UfGridADO1
                  .AddItem Space((preGrade - 1) * 3) & strTotal & vbTab & "" & vbTab & "" & vbTab & "" & _
                     vbTab & FormatCur(preDayYe(preGrade - 1)) & vbTab & "" & vbTab & IIf(toDaySr(preGrade - 1) = 0, "", FormatCur(toDaySr(preGrade - 1))) & vbTab & _
                     IIf(toDayBsr(preGrade - 1) = 0, "", toDayBsr(preGrade - 1)) & vbTab & "" & vbTab & IIf(toDayZc(preGrade - 1) = 0, "", FormatCur(toDayZc(preGrade - 1))) & vbTab & IIf(toDayBzc(preGrade - 1) = 0, "", toDayBzc(preGrade - 1)) & _
                     vbTab & "" & vbTab & FormatCur(toDayYe(preGrade - 1))
               End With
               MakeZero preGrade - 1
            End If
         End If
      Wend
   End With
   DoUnload False
   StatusBar1.Visible = False
   ProBar1.Visible = False
   UfGridADO1.Height = UfGridADO1.Height + StatusBar1.Height
    
    '----设置互斥
    m_bExclude = False

End Sub

Private Sub ChangeStatus(cItemName As String, iChangeUnit As Long, Optional bVisible As Boolean)
   StatusBar1.Panels(2).Text = cItemName
   ProBar1.Value = ProBar1.Value + iChangeUnit
   DoEvents
   
End Sub

'********************************************************************
'*函数说明: 计算资金账户                                              *
'*参    数: iItem_id : 项目编号                                       *
'*                                                                   *
'*返回值  :                                                          *
'*********************************************************************
Private Sub Cal_Khdt(iItem_id As String)
   Dim sqlCal As String
   Dim rsCal As New UfRecordset
   Dim sqlItemss As String
   Dim rsItemss As New UfRecordset
   Dim cExch As String
   Dim dblHl As Double
   Dim m1 As Double
   Dim m2 As Double
   Dim m3 As Double
   Dim M4 As Double
   Dim M5 As Double
   
   sqlItemss = "SELECT ccode FROM FD_Itemss WHERE iitem_id = " & iItem_id & _
      " AND ccode IN (SELECT cAccID FROM FD_AccDef WHERE iDataSrc = 0)"
   Set rsItemss = dbsZJ.OpenRecordset(sqlItemss, dbOpenSnapshot)
   While Not rsItemss.EOF
      sqlCal = "SELECT Sum(mmoney) AS todayMb, " & _
         "Sum(Case When dbill_date = '" & FormatDate(dSearchDate) & "' Then mmoney Else 0 End) AS curMd, " & _
         "0 AS curMc, " & _
         "Sum(Case When dbill_date = '" & FormatDate(dSearchDate) & "' Then 1 Else 0 End) AS mInTemp, " & _
         "0 AS mOut " & _
         "FROM FD_Cred WHERE " & _