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

          'End If
          KeyCode = 0
      Case vbKeyW
          If Shift = vbCtrlMask And Toolbar1.Buttons("Dataout").Enabled Then
              Gen_Key "Dataout"
          End If
          KeyCode = 0
      Case vbKeyF4
          If Shift = vbCtrlMask And Toolbar1.Buttons("Exit").Enabled Then
              Gen_Key "Exit"
          End If
          KeyCode = 0
      Case vbKeyF
          If Shift = vbCtrlMask Then
               Gen_Key "Recx"
          End If
   End Select

End Sub

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

'********************************************************************
'*函数说明: 填充 Grid                                                 *
'*参    数:                                                          *
'*                                                                   *
'*返回值  :                                                          *
'*********************************************************************
Public Sub mCale()
    '----设置互斥
    m_bExclude = True
   
   Dim rsItem As New UfRecordset
   Dim sqlItem As String
   Dim strTotal As String
   Dim iTotal As Boolean
   Dim cExch As String
   Dim dblHl As Variant
   Dim dblX As Variant
   Dim dblY As Variant
   Dim dblZ As Variant
   Dim i As Long
   Dim todayMb As Double
   Dim TendayMb As Double
   Dim MonthMb As Double
   Dim iX As Integer
   
   blnFirstRun = True
   sqlItem = "SELECT * FROM FD_Items WHERE iitems_id=1 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   '从科目取数
               Cal_JszxKm !iItem_id
               todayMb = JszxInfo.mTodayMb
               TendayMb = JszxInfo.mTenday
               MonthMb = JszxInfo.mMonth
               dblX = todayMb
               dblY = TendayMb
               dblZ = MonthMb
               For i = 1 To preGrade
                  toDayYe(i) = toDayYe(i) + todayMb
                  TendayBeginYe(i) = TendayBeginYe(i) + TendayMb
                  MonthBeginYe(i) = MonthBeginYe(i) + MonthMb
               Next i
               cExch = ZjAccInfo.zjStandExch
               dblHl = 1
            Else                 '从账户取数
               '判断此项目下包含内部账户或外部账户或都有
               iX = GetZhStyle(!iItem_id)
               dblX = 0: dblY = 0: dblZ = 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_Jszx !iItem_id
                  With JszxInfo
                     todayMb = .mTodayMb
                     TendayMb = .mTenday
                     MonthMb = .mMonth
                  End With
                  If dblHl = "" Then
                     dblX = "": dblY = "": dblZ = ""
                  Else
                     dblX = todayMb / dblHl
                     dblY = TendayMb / dblHl
                     dblZ = MonthMb / dblHl
                  End If
                  For i = 1 To preGrade
                     toDayYe(i) = toDayYe(i) + todayMb
                     TendayBeginYe(i) = TendayBeginYe(i) + TendayMb
                     MonthBeginYe(i) = MonthBeginYe(i) + MonthMb
                  Next i
               End If
               If iX = 2 Or iX = 3 Then
                  '第二步：从账务账户取数
                  Cal_JszxZh !iItem_id
                  todayMb = JszxInfo.mTodayMb
                  TendayMb = JszxInfo.mTenday
                  MonthMb = JszxInfo.mMonth
                  If dblHl = "" Then
                     dblX = "": dblY = "": dblZ = ""
                  Else
                     dblX = dblX + todayMb / dblHl
                     dblY = dblY + TendayMb / dblHl
                     dblZ = dblZ + MonthMb / dblHl
                  End If
                  For i = 1 To preGrade
                     toDayYe(i) = toDayYe(i) + todayMb
                     TendayBeginYe(i) = TendayBeginYe(i) + TendayMb
                     MonthBeginYe(i) = MonthBeginYe(i) + MonthMb
                  Next i
               End If
            End If
            
            UfGridado1.AddItem Space((preGrade - 1) * 3) & !cItem_Name & vbTab & cExch & vbTab & dblHl & vbTab & FormatCur(dblX) & vbTab & FormatCur(toDayYe(preGrade)) & _
                            vbTab & "" & vbTab & FormatCur(dblY) & vbTab & FormatCur(TendayBeginYe(preGrade)) & vbTab & "" & vbTab & _
                            FormatCur(dblZ) & vbTab & FormatCur(MonthBeginYe(preGrade)) & vbTab & "" & vbTab & "1"
            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(toDayYe(i)) & vbTab & "" & _
                         vbTab & "" & vbTab & FormatCur(TendayBeginYe(i)) & vbTab & "" & vbTab & "" & vbTab & FormatCur(MonthBeginYe(i)) & _
                         vbTab & "" & vbTab & "1"
               End With
               MakeZero i
            Next i
            strTotal = "合计:"
            With UfGridado1
               .AddItem Space(3) & strTotal & vbTab & "" & vbTab & "" & vbTab & "" & vbTab & FormatCur(toDayYe(1)) & _
                      vbTab & "" & vbTab & "" & vbTab & FormatCur(TendayBeginYe(1)) & vbTab & _
                      "" & vbTab & "" & vbTab & FormatCur(MonthBeginYe(1)) & vbTab & "" & vbTab & "1"
            End With
            AddPercent
            MakeZero 1
            iTotal = False
         Else
            If !iGrade < preGrade Then
               strTotal = "小计:"
               With UfGridado1
                  .AddItem Space((preGrade - 1) * 3) & strTotal & vbTab & "" & vbTab & "" & vbTab & "" & vbTab & FormatCur(toDayYe(preGrade - 1)) & _
                               vbTab & "" & vbTab & "" & vbTab & FormatCur(TendayBeginYe(preGrade - 1)) & vbTab & "" & vbTab & _
                               "" & vbTab & FormatCur(MonthBeginYe(preGrade - 1)) & vbTab & "" & vbTab & "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
   With UfGridado1
      If .Rows > 2 Then
         .Row = 2
         '.Col = 0
      End If
   End With
   
    '----设置互斥
    m_bExclude = False

End Sub

'********************************************************************
'*函数说明: 计算资金账户                                              *
'*参    数: iItem_id : 项目编号                                       *
'*                                                                   *
'*返回值  :                                                          *
'*********************************************************************
Private Sub Cal_Jszx(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
   Dim cMBegin As String
   Dim cTBegin As String
   Dim cToday  As String
   Dim cBYear  As String
   Dim oOption As COption
   
   Set oOption = New COption
   oOption.Init dbsZJ
   cBYear = FormatDate(oOption.Option1)
   
   cMBegin = FormatDate(dMonthBegin)
   cTBegin = FormatDate(dTendayBegin)
   cToday = FormatDate(dToday)
   
   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
      'PARAMETERS '" & dMonthBegin & "' DateTime, '" & dTendayBegin & "' DateTime, '" & dToday & "' DateTime, iItemID Long;
      sqlCal = "SELECT Sum(mmoney) AS mTodayMb, " & _
         "Sum(Case When (dbill_date <= '" & cMBegin & "') Then mmoney Else 0 End) AS mMonthbeginMb, " & _
         "Sum(Case When (dbill_date <= '" & cTBegin & "') Then mmoney Else 0 End) AS mTendaybeginMb, " & _
         "Sum(Case When (dbill_date > '" & cMBegin & "' AND dbill_date <= '" & cToday & "') Then (DateDiff(Day, dbill_date, '" & cToday & "') + 1) * mmoney Else 0 End) AS mMonth, " & _
         "Sum(Case When (dbill_date > '" & cTBegin & "' AND dbill_date <= '" & cToday & "') Then (DateDiff(Day, dbill_date, '" & cToday & "') + 1) * mmoney Else 0 End) AS mTenday " & _
         "FROM FD_Cred WHERE " & _
         "cAccID = '" & rsItemss!cCode & "' AND dbill_date <= '" & cToday & _
         "' And dbill_date >= '" & cBYear & "' AND cBookCode IS NOT NULL "
      sqlCal = sqlCal & "UNION ALL SELECT Sum(-mmoney), " & _
         "Sum(Case When (dbill_date <= '" & cMBegin & "') Then -mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date <= '" & cTBegin & "') Then -mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date > '" & cMBegin & "' AND dbill_date <= '" & cToday & "') Then -(DateDiff(Day, dbill_date, '" & cToday & "') + 1) * mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date > '" & cTBegin & "' AND dbill_date <= '" & cToday & "') Then -(DateDiff(Day, dbill_date, '" & cToday & "') + 1) * mmoney Else 0 End) " & _
         "FROM FD_Return WHERE " & _
         "cAccID = '" & rsItemss!cCode & "' AND dbill_date <= '" & cToday & _
         "' And dbill_date >= '" & cBYear & "' AND cBookCode IS NOT NULL "
      sqlCal = sqlCal & "UNION ALL SELECT Sum(-mmoney), " & _
         "Sum(Case When (dbill_date <= '" & cMBegin & "') Then -mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date <= '" & cTBegin & "') Then -mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date > '" & cMBegin & "' AND dbill_date <= '" & cToday & "') Then -(DateDiff(Day, dbill_date, '" & cToday & "') + 1) * mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date > '" & cTBegin & "' AND dbill_date <= '" & cToday & "') Then -(DateDiff(Day, dbill_date, '" & cToday & "') + 1) * mmoney Else 0 End) " & _
         "FROM FD_CreAcrRcp WHERE " & _
         "cAccID = '" & rsItemss!cCode & "' AND dbill_date <= '" & cToday & _
         "' And dbill_date >= '" & cBYear & "' AND cBookCode IS NOT NULL "
      sqlCal = sqlCal & "UNION ALL SELECT Sum(mmoney), " & _
         "Sum(Case When (dbill_date <= '" & cMBegin & "') Then mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date <= '" & cTBegin & "') Then mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date > '" & cMBegin & "' AND dbill_date <= '" & cToday & "') Then (DateDiff(Day, dbill_date, '" & cToday & "') + 1) * mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date > '" & cTBegin & "' AND dbill_date <= '" & cToday & "') Then (DateDiff(Day, dbill_date, '" & cToday & "') + 1) * mmoney Else 0 End) " & _
         "FROM FD_UnwDeb WHERE " & _
         "cGAccID = '" & rsItemss!cCode & "' AND dbill_date <= '" & cToday & _
         "' And dbill_date >= '" & cBYear & "' AND cBookCode IS NOT NULL "
      sqlCal = sqlCal & "UNION ALL SELECT Sum(-mmoney), " & _
         "Sum(Case When (dbill_date <= '" & cMBegin & "') Then -mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date <= '" & cTBegin & "') Then -mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date > '" & cMBegin & "' AND dbill_date <= '" & cToday & "') Then -(DateDiff(Day, dbill_date, '" & cToday & "') + 1) * mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date > '" & cTBegin & "' AND dbill_date <= '" & cToday & "') Then -(DateDiff(Day, dbill_date, '" & cToday & "') + 1) * mmoney Else 0 End) " & _
         "FROM FD_UnwDeb WHERE " & _
         "cPAccID = '" & rsItemss!cCode & "' AND dbill_date <= '" & cToday & _
         "' And dbill_date >= '" & cBYear & "' AND cBookCode IS NOT NULL "
      sqlCal = sqlCal & "UNION ALL SELECT Sum(mmoney), " & _
         "Sum(Case When (dbill_date <= '" & cMBegin & "') Then mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date <= '" & cTBegin & "') Then mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date > '" & cMBegin & "' AND dbill_date <='" & cToday & "') Then (DateDiff(Day, dbill_date, '" & cToday & "') + 1) * mmoney Else 0 End), " & _
         "Sum(Case When (dbill_date > '" & cTBegin & "' AND dbill_date <= '" & cToday & "') Then (DateDiff(Day, dbill_date, '" & cToday & "') + 1) * mmoney Else 0 End) " & _
         "FROM FD_UnwRet WHERE " & _
         "cGAccID = '" & rsItemss!cCode & "' AND dbill_date <= '" & cToday & _
         "' And dbill_date >= '" & cBYear & "' AND cBookCode IS NOT NULL "