dareportsk.dsr

VB数据库设计的代码。需要根据自己的数据库再作调整

         Object.Left            =   3969
         Object.Top             =   3402
         Object.Width           =   1125
         Object.Height          =   570
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "Arial"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Object.Caption         =   "0"
      EndProperty
      ItemType46      =   3
      BeginProperty Item46 {1C13A8E1-A0B6-11D0-848E-00A0C90DC8A9} 
         _Version        =   393216
         Name            =   "Label6"
         Object.Left            =   3969
         Object.Top             =   3969
         Object.Width           =   1125
         Object.Height          =   570
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "Arial"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Object.Caption         =   "0"
      EndProperty
      ItemType47      =   3
      BeginProperty Item47 {1C13A8E1-A0B6-11D0-848E-00A0C90DC8A9} 
         _Version        =   393216
         Name            =   "Label11"
         Object.Left            =   3969
         Object.Top             =   6803
         Object.Width           =   1125
         Object.Height          =   570
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "Arial"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Object.Caption         =   "0"
      EndProperty
   EndProperty
   SectionCode3    =   7
   BeginProperty Section3 {1C13A8E0-A0B6-11D0-848E-00A0C90DC8A9} 
      _Version        =   393216
      Name            =   "Section3"
      Object.Height          =   870
      NumControls     =   0
   EndProperty
   SectionCode4    =   8
   BeginProperty Section4 {1C13A8E0-A0B6-11D0-848E-00A0C90DC8A9} 
      _Version        =   393216
      Name            =   "Section5"
      Object.Height          =   360
      NumControls     =   0
   EndProperty
End
Attribute VB_Name = "Dareportsjyzb1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub DataReport_Initialize()
    Dim m_xm(35) As String
    Dim m_bq(6) As Variant
    Dim m_bl(5) As Variant
    Dim m_yys(5) As String
    Dim i, j As Integer
    m_yys(0) = "本期"
    m_yys(1) = "移动"
    m_yys(2) = "联通"
    m_yys(3) = "电信"
    m_yys(4) = "网通"
    m_yys(5) = "其他"
    Dim m_xmbq As Variant
    Dim m_ydbq As Variant
    Dim m_ltbq As Variant
    Dim m_dxbq As Variant
    Dim m_wtbq As Variant
    Dim m_qtbq As Variant
    Dim m_ydbl As Variant
    Dim m_ltbl As Variant
    Dim m_dxbl As Variant
    Dim m_wtbl As Variant
    Dim m_qtbl As Variant
    Dim str As String
    Dim AdoCon As New ADODB.Connection
    Const iW = 3 '缇,误差调整
    Printer.PaperSize = 9
    Dareportsk.ReportWidth = Printer.Width - Dareportsk.LeftMargin - Dareportsk.RightMargin - iW
    Dim AdoRec As New ADODB.Recordset
    Dim txt As New Collection
    Dim ctl As Object
     Dim ctl1 As Object
    'AdoCon.Open "Provider=SQLOLEDB.1;Password=db0822;Persist Security Info=True;User ID=sa;Initial Catalog=htgl;Data Source=JX"
   AdoCon.Open nowconnectstring
   AdoCon.Execute ("delete from bbsk")
   AdoRec.Open "select * from dyxx", AdoCon
   m_xm(0) = "本期到款金额"
   m_xm(1) = "本期应收金额"
   j = 2
   Do While Not AdoRec.EOF
     m_xm(j) = AdoRec.Fields("dymc").Value
     AdoRec.MoveNext
     j = j + 1
   Loop
   AdoRec.Close
   For i = 0 To 34
     For j = 0 To 5
       m_bq(j) = 0
     Next j
     For j = 0 To 4
       m_bl(j) = 0
     Next j
     Select Case i
       Case 0
'          AdoRec.Close
          AdoRec.Open "select sum(dk) as aa from hetong ", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
            m_bq(0) = AdoRec.Fields("aa").Value
          End If
          AdoRec.Close
          If m_bq(0) = 0 Then
            GoTo l0
          End If
          AdoRec.Open "select sum(dk) as aa from hetong where yys like '%移动%' ", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
            m_bq(1) = AdoRec.Fields("aa").Value
            m_bl(0) = m_bq(1) / m_bq(0)
          End If
          AdoRec.Close
          AdoRec.Open "select sum(dk) as aa from hetong where yys like '%联通%' ", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
            m_bq(2) = AdoRec.Fields("aa").Value
            m_bl(1) = m_bq(2) / m_bq(0)
          End If
          AdoRec.Close
          AdoRec.Open "select sum(dk) as aa from hetong where yys like '%电信%' ", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
             m_bq(3) = AdoRec.Fields("aa").Value
             m_bl(2) = m_bq(3) / m_bq(0)
          End If
          AdoRec.Close
          AdoRec.Open "select sum(dk) as aa from hetong where yys like '%网通%' ", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
            m_bq(4) = AdoRec.Fields("aa").Value
            m_bl(3) = m_bq(4) / m_bq(0)
          End If
          AdoRec.Close
          AdoRec.Open "select sum(dk) as aa from hetong where yys like '%其他%' or yys like '%邮政%' ", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
            m_bq(5) = AdoRec.Fields("aa").Value
            m_bl(4) = m_bq(5) / m_bq(0)
          End If
          AdoRec.Close
l0:
          'AdoCon.Execute ("DBCC CHECKIDENT (bbsk, RESEED, 0)")
          
          str = "insert into bbsk (xm,bqzs,ydbq,ydbl,ltbq,ltbl,dxbq,dxbl,wtbq,wtbl,qtbq,qtbl) values('" & m_xm(i) & "'," & m_bq(0) & "," & m_bq(1) & "," & m_bl(0) & "," & m_bq(2) & "," & m_bl(1) & "," & m_bq(3) & "," & m_bl(2) & "," & m_bq(4) & "," & m_bl(3) & "," & m_bq(5) & "," & m_bl(4) & ")"
          AdoCon.Execute str
        Case 1
          AdoRec.Open "select sum(yinszk) as aa from hetong ", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
             m_bq(0) = AdoRec.Fields("aa").Value
          End If
          AdoRec.Close
          If m_bq(0) = 0 Then
            GoTo l1
          End If
          AdoRec.Open "select sum(yinszk) as aa from hetong where yys like '%移动%' ", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
            m_bq(1) = AdoRec.Fields("aa").Value
            m_bl(0) = m_bq(1) / m_bq(0)
          End If
          AdoRec.Close
          AdoRec.Open "select sum(yinszk) as aa from hetong where yys like '%联通%' ", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
             m_bq(2) = AdoRec.Fields("aa").Value
             m_bl(1) = m_bq(2) / m_bq(0)
          End If
          AdoRec.Close
          AdoRec.Open "select sum(yinszk) as aa from hetong where yys like '%电信%' ", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
             m_bq(3) = AdoRec.Fields("aa").Value
             m_bl(2) = m_bq(3) / m_bq(0)
          End If
          AdoRec.Close
          AdoRec.Open "select sum(yinszk) as aa from hetong where yys like '%网通%' ", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
             m_bq(4) = AdoRec.Fields("aa").Value
             m_bl(3) = m_bq(4) / m_bq(0)
          End If
          AdoRec.Close
          AdoRec.Open "select sum(yinszk) as aa from hetong where yys like '%其他%' or yys like '%邮政%' ", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
            m_bq(5) = AdoRec.Fields("aa").Value
            m_bl(4) = m_bq(5) / m_bq(0)
          End If
          AdoRec.Close
l1:
          'AdoCon.Execute ("DBCC CHECKIDENT (bbsk, RESEED, 0)")
          str = "insert into bbsk (xm,bqzs,ydbq,ydbl,ltbq,ltbl,dxbq,dxbl,wtbq,wtbl,qtbq,qtbl) values('" & m_xm(i) & "'," & m_bq(0) & "," & m_bq(1) & "," & m_bl(0) & "," & m_bq(2) & "," & m_bl(1) & "," & m_bq(3) & "," & m_bl(2) & "," & m_bq(4) & "," & m_bl(3) & "," & m_bq(5) & "," & m_bl(4) & ")"
          AdoCon.Execute str
       Case Else
          'm_xm(I) = "本期应收账款金额"
          AdoRec.Open "select sum(yinszk) as aa from hetong where dymc like '" & m_xm(i) & "'", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
             m_bq(0) = AdoRec.Fields("aa").Value
          End If
          AdoRec.Close
          If m_bq(0) = 0 Then
            GoTo l2
          End If
          AdoRec.Open "select sum(yinszk) as aa from hetong where yys like '%移动%' and dymc like '" & m_xm(i) & "'", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
             m_bq(1) = AdoRec.Fields("aa").Value
             m_bl(0) = m_bq(1) / m_bq(0)
          End If
          AdoRec.Close
          AdoRec.Open "select sum(yinszk) as aa from hetong where yys like '%联通%' and dymc like '" & m_xm(i) & "' ", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
             m_bq(2) = AdoRec.Fields("aa").Value
             m_bl(1) = m_bq(2) / m_bq(0)
          End If
          AdoRec.Close
          AdoRec.Open "select sum(yinszk) as aa from hetong where yys like '%电信%' and dymc like '" & m_xm(i) & "'", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
             m_bq(3) = AdoRec.Fields("aa").Value
             m_bl(2) = m_bq(3) / m_bq(0)
          End If
          AdoRec.Close
          AdoRec.Open "select sum(yinszk) as aa from hetong where yys like '%网通%' and dymc like '" & m_xm(i) & "'", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
             m_bq(4) = AdoRec.Fields("aa").Value
             m_bl(3) = m_bq(4) / m_bq(0)
          End If
          AdoRec.Close
          AdoRec.Open "select sum(yinszk) as aa from hetong where (yys like '%其他%' or yys like '%邮政%') and dymc like '" & m_xm(i) & "'", AdoCon
          If Not IsNull(AdoRec.Fields("aa").Value) Then
             m_bq(5) = AdoRec.Fields("aa").Value
             m_bl(4) = m_bq(5) / m_bq(0)
          End If
          AdoRec.Close
l2:
          'AdoCon.Execute ("DBCC CHECKIDENT (bbds, RESEED, 0)")
          If (m_bq(0) + m_bq(1) + m_bq(2) + m_bq(3) + m_bq(4)) > 0 Then
             str = "insert into bbsk (xm,bqzs,ydbq,ydbl,ltbq,ltbl,dxbq,dxbl,wtbq,wtbl,qtbq,qtbl) values('" & m_xm(i) & "'," & m_bq(0) & "," & m_bq(1) & "," & m_bl(0) & "," & m_bq(2) & "," & m_bl(1) & "," & m_bq(3) & "," & m_bl(2) & "," & m_bq(4) & "," & m_bl(3) & "," & m_bq(5) & "," & m_bl(4) & ")"
             AdoCon.Execute str
          End If
     End Select
   Next i
   DataEnvironment1.rscmd1.Requery
   'AdoCon.Execute "DROP TABLE aa"
    'AdoCon.Execute "select  IDENTITY(INT)AS xuhao,htbh,htmc,qdsj,kpsj,kpje,yjskje,fzr,yys,dymc into aa from hetong where wgqk like '%未完工%' and qdsj>'" & starttime & "' and qdsj<'" & endtime & "' order by kpsj"
    'AdoRec.Open "select * from bbsk ", AdoCon
   ' Set Dareportsk.DataSource = AdoRec
    For Each ctl1 In Me.Sections.Item("Section2").Controls
     If TypeName(ctl1) = "RptLabel" Then
      Select Case ctl1.Name
        Case "Label21"
          ctl1.Caption = "起始时间：" & starttime
        Case "Label23"
          ctl1.Caption = "截至时间：" & endtime
      End Select
     End If
    Next
    'For Each ctl In Me.Sections.Item("Section1").Controls
   ' If TypeName(ctl) = "RptTextBox" Then
   ' Select Case ctl.Name
   ' Case "Text1"
    'ctl.DataField = AdoRec.Fields("xm").Name
   ' Case "Text2"
   ' ctl.DataField = AdoRec.Fields("bqzs").Name
   ' Case "Text3"
   ' ctl.DataField = AdoRec.Fields("ydbq").Name
  '  Case "Text4"
    'ctl.DataField = AdoRec.Fields("ydbl").Name
   ' Case "Text5"
    'ctl.DataField = AdoRec.Fields("ltbq").Name
    'Case "Text6"
   ' ctl.DataField = AdoRec.Fields("ltbl").Name
   ' Case "Text7"
    'ctl.DataField = AdoRec.Fields("dxbq").Name
   ' Case "Text8"
    'ctl.DataField = AdoRec.Fields("dxbl").Name
   ' Case "Text9"
    'ctl.DataField = AdoRec.Fields("wtbq").Name
   ' Case "Text10"
   'ctl.DataField = AdoRec.Fields("wtbl").Name
   ' Case "Text11"
    'ctl.DataField = AdoRec.Fields("qtbq").Name
   ' Case "Text12"
   ' ctl.DataField = AdoRec.Fields("qtbl").Name
   ' End Select
   ' End If
   ' Next
End Sub