SQL实现报表功能

查询

查询按钮点击事件脚本
//查询功能：

Sub OnClick(ByVal Item)

Dim conn '定义类对象
Dim SCon '定义数据库连接字符串
Dim oRs1 '定义获取到的数据集
Dim oCom
Dim strSQL1
Dim m,i,j,k

'---------------------打开数据库 --------------------'
sCon= "Provider=SQLOLEDB; Integrated Security =SSPI;Persist Security Info=False; Initial Catalog=Hong ; Data Source=DESKTOPDELL"
Set conn=CreateObject("ADODB.Connection")
conn.ConnectionString = sCon
conn.CursorLocation = 3
conn.Open
Set oRs1 = CreateObject("ADODB.Recordset")
Set oCom = CreateObject("ADODB.Command")
oCom.CommandType = 1

' --------------------时间控件-----------------------'
Dim Obj1,dateStart,Obj2,dateEnd

Set Obj1=ScreenItems("StartData")
Set Obj2=ScreenItems("EndData")

dateStart=Obj1.Value
dateEnd=Obj2.Value
MsgBox ("开始时间: " & dateStart & vbCrLf & "结束时间: " & dateEnd)
'---------------------查询数据库 --------------------'
strSQL1= "SELECT * FROM [Hong].[dbo].[DataTableTest] WHERE [Datetime] BETWEEN '"& dateStart &"' AND '"& dateEnd &"' ORDER BY [Datetime] ASC"

Msgbox(strSQL1)

Set oCom.ActiveConnection = conn
oCom.CommandText = strSQL1
Set oRs1 = oCom.Execute

m = oRs1.RecordCount
MsgBox("查询到表格共有" & m &"行数据")

'---------------------设置MSHFlexGrid控件显示--------------------'
Dim olist
Set olist = ScreenItems("ReCon")
olist.clear
olist.Cols=5 '列数
olist.Rows = m+1 '行数量

For i = 0 To 4
olist.ColAlignment(i)=3'列内容居中显示
Next

'设置列宽    
olist.ColWidth(0) = 800                 
olist.ColWidth(1) = 1200
olist.ColWidth(2) = 2000
olist.ColWidth(3) = 1200
olist.ColWidth(4) = 1200

'设置表头
oList.TextMatrix(0, 0)= "序号"   

oList.TextMatrix(0, 1)= "ID"
oList.TextMatrix(0, 2) = "时间"
oList.TextMatrix(0, 3) = "测试1"
oList.TextMatrix(0, 4) = "测试2"

'---------------------将数据写入表格--------------------'
oRs1.movefirst
For i = 1 To m
oList.TextMatrix(i ,0) = i
oList.TextMatrix(i ,1) = oRs1.Fields(0).Value
oList.TextMatrix(i ,2) = oRs1.Fields(1).Value
oList.TextMatrix(i ,3) = oRs1.Fields(2).Value
oList.TextMatrix(i ,4) = oRs1.Fields(3).Value
oRs1.movenext
Next
MsgBox("查询结束" )
'----------------关闭数据库-----------'
Set oRs1 = Nothing
Set oCom = Nothing
conn.Close
Set conn = Nothing

End Sub

保存
保存按钮单击事件脚本
//指定日期文件保存功能：

Sub OnClick(ByVal Item)

Dim conn '定义类对象
Dim SCon '定义数据库连接字符串
Dim oRs1 '定义获取到的数据集
Dim oCom
Dim strSQL1
Dim m
Dim ReportSelect
'----------------------------------------------------------
Dim Obj1,dateStart,Obj2,dateEnd
Set Obj1=ScreenItems("StartData")
Set Obj2=ScreenItems("EndData")
dateStart=Obj1.Value
dateEnd=Obj2.Value
'---------------------打开并查询数据库 --------------------'
sCon= "Provider=SQLOLEDB.1; Integrated Security =SSPI;Persist Security Info=False; Initial Catalog=Hong ; Data Source=DESKTOPDELL"
strSQL1= "SELECT * FROM [Hong].[dbo].[DataTableTest] WHERE [Datetime] BETWEEN '"& dateStart &"' AND '"& dateEnd &"' ORDER BY [Datetime] ASC"
Set conn=CreateObject("ADODB.Connection")
conn.ConnectionString = sCon
conn.CursorLocation = 3
conn.Open
Set oRs1 = CreateObject("ADODB.Recordset")
Set oCom = CreateObject("ADODB.Command")
oCom.CommandType = 1
Set oCom.ActiveConnection = conn
oCom.CommandText = strSQL1
Set oRs1 = oCom.Execute
m = oRs1.RecordCount
MsgBox("查询到表格共有" & m &"行数据")

'---------------------打开Excel模板 --------------------'
Dim objExcelApp,objExcelBook,objExcelSheet,a,b ,i
Set objExcelApp =CreateObject("Excel.Application")
objExcelApp.Visible=True
Set a =objExcelApp.Workbooks.Open("D:\DataTableTest.xlsx")
Set b =a.Worksheets("Sheet1")
b.Range("A2") = "日期: " & CStr(Year(Now)) & "年" & CStr(Month(Now)) &"月" & CStr(Day(Now)) &"日"
objExcelApp.Worksheets("Sheet1").Activate
'---------------------判断有无符合要求的数据 --------------------'
If (oRs1.EOF) Then
MsgBox("没有符合要求的记录")
Else
MsgBox("符合要求的记录")
oRs1.movefirst
For i = 4 To m+3

        With objExcelApp.Worksheets("Sheet1")
        .cells(i,1).value=CStr(oRs1.Fields(0).Value)
        .cells(i,2).value=CStr(oRs1.Fields(1).Value)
        .cells(i,3).value=CStr(oRs1.Fields(2).Value)
        .cells(i,4).value=CStr(oRs1.Fields(3).Value)
        End With
        oRs1.MoveNext
    Next

End If

'---------------------以日期命名，并保存到指定文件夹 --------------------'
Dim patch,filename
filename=CStr(Year(Now))&""&CStr(Month(Now))&""&CStr(Day(Now))&""&CStr(Hour(Now))&""&CStr(Minute(Now))&"_"&CStr(Second(Now))
patch= "D:\日报表"&filename&".xlsx"
objExcelApp.ActiveWorkbook.SaveAs patch
objExcelApp.Workbooks.Close
objExcelApp.Quit

     MsgBox "成功生成数据文件!"

'---------------------关闭数据库 --------------------'
Set objExcelApp= Nothing
Set oRs1 = Nothing
Set oCom = Nothing
conn.Close
Set conn = Nothing

End Sub