+-+

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

               f0 = ""
               sqlAccCount = "SELECT cAccID FROM FD_AccDef WHERE cAccID IN" & sqlSubSelect
               Set rsAccCount = dbsZJ.OpenRecordset(sqlAccCount, dbOpenSnapshot)
               If Not rsAccCount.EOF Then
                  rsAccCount.MoveLast
                  If rsAccCount.RecordCount = 1 Then
                     f0 = rsAccCount!cAccID
                  End If
               End If
               
               sqlCale = "SELECT * " & _
                  "FROM FD_AccSum WHERE cAccID IN" & sqlSubSelect & _
                  "AND dbill_date = '" & FormatDate(dStartDate) & "' "
               Set rsCale = dbsZJ.OpenRecordset(sqlCale, dbOpenSnapshot)
               todayMb = 0: todayMh = 0
               With rsCale
                  While Not .EOF
                     dblHl_er = GetAccHl(!cAccID)
                     todayMb = todayMb + !Mb * dblHl_er
                     todayMh = todayMh + !Mh * dblHl_er
                     .MoveNext
                  Wend
               End With
               
               Dim DqMb As Double
               Dim DqMh As Double
               
               sqlAccCount = "SELECT cAccID FROM FD_AccDef WHERE cAccID IN" & _
                  sqlSubSelect & " AND itype=0"
               Set rsAccCount = dbsZJ.OpenRecordset(sqlAccCount, dbOpenSnapshot)
               With rsAccCount
                  While Not .EOF
                     dblHl_er = GetAccHl(!cAccID)
                     Getdq_mbmh !cAccID, DqMb, DqMh
                     todayMb = todayMb + DqMb * dblHl_er
                     todayMh = todayMh + DqMh * dblHl_er
                     .MoveNext
                  Wend
               End With
               
               If dblHl = "" Then
                  dblX = ""
               Else
                  dblX = todayMb / dblHl
               End If
               For i = 1 To preGrade
                  toDayYe(i) = toDayYe(i) + todayMb
                  toMh(i) = toMh(i) + todayMh
               Next i
            End If
            
            '---- Change DC Direction , 贷方为正(加贷减借)
            
            UfGridADO1.AddItem f0 & vbTab & Space((preGrade - 1) * 3) & !cItem_Name & vbTab & _
                  cExch & vbTab & dblHl & vbTab & IIf(dblX = "", "", Format(dblX, "#,##0.00")) & vbTab & _
                  Format(toDayYe(preGrade), "#,##0.00") & vbTab & Format(toMh(preGrade), "#,##0.00")
            If preGrade <> 1 Then MakeZero preGrade
         Else              ' 非末级
            UfGridADO1.AddItem vbTab & 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 vbTab & Space(i * 3) & strTotal & vbTab & "" & vbTab & "" & _
                     vbTab & "" & vbTab & Format(toDayYe(i), "#,##0.00") & _
                     vbTab & Format(toMh(i), "#,##0.00")
               End With
               MakeZero i
            Next i
            strTotal = "合计:"
            With UfGridADO1
               .AddItem vbTab & Space(3) & strTotal & vbTab & "" & vbTab & "" & vbTab & _
                  "" & vbTab & Format(toDayYe(1), "#,##0.00") & _
                  vbTab & Format(toMh(1), "#,##0.00")
            End With
            MakeZero 1
            iTotal = False
         Else
            If !iGrade < preGrade Then
               
               strTotal = "小计:"
               With UfGridADO1
                  .AddItem vbTab & Space((preGrade - 1) * 3) & strTotal & vbTab & "" & _
                        vbTab & "" & vbTab & "" & vbTab & _
                        Format(toDayYe(preGrade - 1), "#,##0.00") & _
                        vbTab & Format(toMh(preGrade - 1), "#,##0.00")
               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
'      .Row = .Rows - 1
'      .Col = 0
'   End With
    '----设置互斥
    m_bExclude = False

   
End Sub

'********************************************************************
'*函数说明: 计算从定期数据                                            *
'*参    数: cAccID ：账户号                                          *
'*          DqMb : 余额                                              *
'*          DqMh : 积数                                              *
'*返回值  :                                                          *
'*********************************************************************
Private Sub Getdq_mbmh(cAccID As String, DqMb As Double, DqMh As Double)
   Dim sqlX As String
   Dim rsX As New UfRecordset
   Dim sqlY As String
   Dim rsY As New UfRecordset
   
   DqMb = 0: DqMh = 0
   sqlX = "SELECT cSavID, mmoney, dbill_date, bSettle FROM FD_Sav WHERE cAccID='" & cAccID & "' AND dbill_date <= '" & FormatDate(dStartDate) & "'"
   Set rsX = dbsZJ.OpenRecordset(sqlX, dbOpenSnapshot)
   While Not rsX.EOF
      If rsX!bSettle Then
         sqlY = "SELECT dbill_date FROM FD_Fetch WHERE cAccID='" & cAccID & "'"
         Set rsY = dbsZJ.OpenRecordset(sqlY, dbOpenSnapshot)
         If Not rsY.EOF Then
            If rsY!dbill_date <= dStartDate Then GoTo GoToNext
         End If
      End If
      DqMb = DqMb + rsX!mMoney
      DqMh = DqMh + rsX!mMoney * DqCalcDays(rsX!dbill_date, dStartDate)
GoToNext:
      rsX.MoveNext
   Wend
   
End Sub

'********************************************************************
'*函数说明: 计算从科目取数                                            *
'*参    数: iItem_id : 项目编号                                       *
'*                                                                   *
'*返回值  :                                                          *
'*********************************************************************
Private Sub Cal_KhyeKm(iItem_id As String)
   Dim sqlCale    As String
   Dim rsCale     As New UfRecordset
   Dim sqlItem    As String
   Dim rsItem     As New UfRecordset
   Dim blnPrpty   As Boolean
   Dim mQc        As Double
   Dim m1         As Double
   Dim m2         As Double
   
   sqlItem = "SELECT ccode FROM FD_Itemss WHERE iitem_id=" & iItem_id
   Set rsItem = dbsZJ.OpenRecordset(sqlItem, dbOpenSnapshot)
   With rsItem
   While Not .EOF
      blnPrpty = GetKmPropty(!cCode)
      '---- Change DC Direction , 贷方为正(加贷减借)
      Dim curTmp  As Double
      curTmp = GetKmQC(!cCode, blnPrpty)
      mQc = mQc + IIf(blnPrpty, curTmp, -curTmp)
      sqlCale = "SELECT Sum(md-mc) AS todayMb, " & _
         "Sum(Case When dbill_date <= '" & FormatDate(ZjAccInfo.zjStartdate) & _
         "' Then (DateDiff(Day, '" & FormatDate(ZjAccInfo.zjStartdate) & "', '" & FormatDate(dStartDate) & "') + 1) * (md - mc) " & _
         "Else (DateDiff(Day, dbill_date, '" & FormatDate(dStartDate) & "') + 1) * (md - mc) End) AS todayMh " & _
         "FROM GL_accVouch " & _
         "WHERE ccode LIKE '" & !cCode & "%' " & _
         "AND iperiod >= 1 And iperiod <=12 AND iflag IS NULL AND dbill_date <= '" & FormatDate(dStartDate) & "'"
      Set rsCale = dbsZJ.OpenRecordset(sqlCale, dbOpenSnapshot)
      With rsCale
      '---- Change DC Direction , 贷方为正(加贷减借)
         If Not .EOF Then
            m1 = m1 + IIf(IsNull(!todayMb), 0, IIf(blnPrpty, !todayMb, -!todayMb))
            m2 = m2 + IIf(IsNull(!todayMh), 0, IIf(blnPrpty, !todayMh, -!todayMh))
         End If
      End With
      rsItem.MoveNext
   Wend
   End With
   With KhyeInfor
      .Mb = mQc + m1
      .Mh = m2
   End With
   CloseRS rsItem
   CloseRS rsCale
End Sub

'********************************************************************
'*函数说明: 计算账户汇率                                              *
'*参    数: cAccID : 账户号                                          *
'*                                                                   *
'*返回值  :                                                          *
'*********************************************************************
Private Function GetAccHl(cAccID As String)
   'CuiDong Efficiency-A 2000/06/20 效率优化A OK
   Dim rsAcc As New UfRecordset
'   Set rsAcc = dbsZJ.OpenRecordset("FD_AccDef")  'CuiDong Efficiency-A 2000/06/20 效率优化A
   Set rsAcc = dbsZJ.OpenRecordset("Select * From FD_AccDef Where cAccID = '" & cAccID & "'") 'CuiDong Efficiency-A 2000/06/20 效率优化A
   With rsAcc
'      .FindFirst "cAccID = '" & cAccID & "'"     'CuiDong Efficiency-A 2000/06/20 效率优化A
'      If Not .NoMatch Then                       'CuiDong Efficiency-A 2000/06/20 效率优化A
      If Not (.EOF Or .BOF) Then                  'CuiDong Efficiency-A 2000/06/20 效率优化A
         GetAccHl = GetCurHl(!cexch_name, zjLogInfo.curDate)
      End If
   End With
   rsAcc.oClose
   Set rsAcc = Nothing
End Function

Private Sub MakeZero(iGrade As Long)
   toDayYe(iGrade) = 0
   toMh(iGrade) = 0
   
End Sub

Private Sub DoUnload(blnLoad As Boolean)
   DoUnloadInfo.blnRKhmx = blnLoad
End Sub

'********************************************************************
'*函数说明: 初始化  Grid                                             *
'*参    数:                                                          *
'*                                                                   *
'*返回值  :                                                          *
'*********************************************************************
Public Sub initGrid()
   Dim i As Integer
   Dim rsHead As New UfRecordset, sqlHead As String
   sqlHead = "SELECT * FROM FD_Item WHERE iitems_id=3"
   Set rsHead = dbsZJ.OpenRecordset(sqlHead, dbOpenSnapshot)
   Label4 = rsHead!citems_name
   lblTime = Year(dStartDate) & "年 " & Month(dStartDate) & "月 " & Day(dStartDate) & "日"
   
   With UfGridADO1
      ' 设置表头
      .Rows = 0
      DoEvents
      .Redraw = True
      .Cols = 7
      .Rows = 2
      .FixedCols = 0
      .FixedRows = 2
      .TextMatrix(0, 0) = "账号"
      .TextMatrix(1, 0) = "账号"
      .JoinCells 0, 0, 1, 0, True
      
      .TextMatrix(0, 1) = "户名及类别"
      .TextMatrix(1, 1) = "户名及类别"
      .JoinCells 0, 1, 1, 1, True
      
      .TextMatrix(0, 2) = "币别"
      .TextMatrix(1, 2) = "币别"
      .JoinCells 0, 2, 1, 2, True
      
      .TextMatrix(0, 3) = "汇率"
      .TextMatrix(1, 3) = "汇率"
      .JoinCells 0, 3, 1, 3, True
      
      .TextMatrix(0, 4) = "资金余额"
      .TextMatrix(1, 4) = "资金余额"
      .JoinCells 0, 4, 1, 4, True
      
      .TextMatrix(0, 5) = "资金余额(本位币)"
      .TextMatrix(1, 5) = "资金余额(本位币)"
      .JoinCells 0, 5, 1, 5, True
      
      .TextMatrix(0, 6) = "资金积数"
      .TextMatrix(1, 6) = "资金积数"
      .JoinCells 0, 6, 1, 6, True
      
      ' 设置宽度
      For i = 0 To 6
          Select Case i
              Case 0, 1
                  .ColWidth(i) = 2000
              Case 2, 3
                  .ColWidth(i) = 700
              Case 4, 5, 6
                  .ColWidth(i) = 2000
          End Select
      Next i
   
      '设置表体的Alignment
      For i = 0 To 6
          Select Case i
              Case 0, 1
                  .ColAlignment(i) = UG_ALIGNLEFT
              Case 2
                  .ColAlignment(i) = UG_ALIGNCENTER
              Case 3, 4, 5, 6
                  .ColAlignment(i) = UG_ALIGNRIGHT
          End Select
      Next i
      
      .HeadFont.Name = "宋体"
      .HeadFont.Size = 9
      .HeadBackColor = &H8000000E
      .HeadFont.Bold = True
   End With
   Set frmRptItem.mCollectColWidth = New Collection
   For i = 0 To 6
      frmRptItem.mCollectColWidth.Add UfGridADO1.ColWidth(i), CStr(i)
   Next i
   
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   Cancel = DoUnloadInfo.blnRKhmx
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

Private Sub Form_Resize()
   On Error Resume Next
   If Me.WindowState <> 1 Then
      If Me.Width < frmMinWidth Then Me.Width = frmMinWidth
      If Me.Height < frmMinWidth Then Me.Height = frmMinWidth
      UfGridADO1.Width = Me.Width - 100
      UfGridADO1.Height = Me.Height - Toolbar1.Height - Picture1.Height - 400 - IIf(StatusBar1.Visible, StatusBar1.Height, 0)
      UfGridADO1.Top = Toolbar1.Height + Picture1.Height
      UfGridADO1.Left = 0
      Picture1.Left = Me.Width - Picture1.Width
      Label4.Left = Me.Width / 2 - Label4.Width / 2 + (Picture1.Width - Me.Width)
      lblTime.Left = Me.Width - lblTime.Width - 200 + (Picture1.Width - Me.Width)
      ProBar1.Left = 4860
      ProBar1.Top = Me.Height - 640
   End If
   On Error GoTo 0
End Sub

Private Sub Recx()
   With frmReportXz
      .Quitfs = False
      .strReportType = "Khye"
      .Show vbModal
   End With
End Sub

Private Sub Gen_Key(TLB_Key As String)
    '----设置互斥
    If m_bExclude = True Then Exit Sub
   
   Select Case TLB_Key
        Case Is = "Print", "Preview", "Dataout"
            If TLB_Key = "Dataout" Then InitDataOut
            zjbPrnViewOut Me, "khyeb", TLB_Key, True, Label4.Caption, "", "", lblTime.Caption
      Case "Recx"
         Recx
      Case "Item"
         With frmRptItem
            Set .mGrid = Me.UfGridADO1
            .mStartCol = 2
            .mEndCol = 6
            .Show vbModal
         End With
      Case "Help"
         SendKeys "{F1}"
      Case "Exit"
         Unload Me
   End Select

End Sub

Private Sub Form_Unload(Cancel As Integer)
   Dim i As Long
   For i = 1 To 4
      toDayYe(i) = 0
      toMh(i) = 0
   Next i
    zjLogInfo.TaskExec "FD0703", 0, zjLogInfo.cIYear
    zjLogInfo.ClearError
    zjGen_arr.FD0703 = False
End Sub

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