Public Enum ExportType
DiffrentData = 0
FirstData = 1
SecondData = 2
End Enum
Public Function BuildSheet(ByRef xlSheet As Excel.Worksheet,ByVal strsql As String,ByVal oType As ExportType)
Dim Rs_Data As ADODB.Recordset
Dim xlQuery As Excel.QueryTable
Dim Irowcount As Long
Dim Icolcount As Long
On Error GoTo ErrHandle
Select Case oType
Case ExportType.DiffrentData
xlSheet.Name = "sheet1"
Case ExportType.FirstData
xlSheet.Name = "sheet2"
Case ExportType.SecondData
xlSheet.Name = "sheet3"
End Select
Set Rs_Data = New ADODB.Recordset
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = gConnection
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.source = strsql
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
'添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data,xlSheet.Range("a1"))
With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With
xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh
With xlSheet
.Range(.Cells(1,1),.Cells(1,Icolcount)).Font.Name = "黑体"
.Range(.Cells(1,Icolcount)).Interior.Color = vbYellow
'设标题为黑体字
.Range(.Cells(1,Icolcount)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1,.Cells(Irowcount + 1,Icolcount)).Borders.Linestyle = xlContinuous
'设表格边框样式
End With
With xlSheet.PageSetup
.LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称：" ' & Gsmc
.CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
.RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
.LeftFooter = "&""楷体_GB2312,常规""&10制表人："
.CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
.RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
End With
Rs_Data.Close
Set Rs_Data = nothing
On Error GoTo 0
Exit Function
ErrHandle:
Call gErrList("frmDoubleKeyRpt.BuildSheet",Err.Description,Err.Number,True)
End Function
Public Function ExporToExcelBysql(strsql As String,strFirstDatasql As String,strSecondDatasql As String)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(SQL查询字符串)
'*********************************************************
Dim Irowcount As Long
Dim Icolcount As Long
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
Dim strDate As String
Dim StrFileName As String
Dim i As Integer
On Error GoTo ErrHandle
strDate = Format(Date,"YYYYMMDD")
'strFileName = App.Path & "\录入清单_Test_" & strDate & ".xls"
Set xlApp = CreateObject("Excel.Application")
Set xlBook = nothing
Set xlSheet = nothing
Set xlBook = xlApp.Workbooks().Add
'添加两个Sheet，保证有三个Sheet
Set xlSheet = xlBook.Sheets.Add
Set xlSheet = xlBook.Sheets.Add
'添加Sheet数据1
Set xlSheet = xlBook.Worksheets(1)
Call BuildSheet(xlSheet,strsql,ExportType.DiffrentData)
'添加Sheet数据2
Set xlSheet = xlBook.Worksheets(2)
Call BuildSheet(xlSheet,strFirstDatasql,ExportType.FirstData)
'添加Sheet数据3
Set xlSheet = xlBook.Worksheets(3)
Call BuildSheet(xlSheet,strSecondDatasql,ExportType.SecondData)
xlApp.Application.Visible = True
xlBook.Saved = True
xlBook.SavecopyAs StrFileName
Set xlApp = nothing '"交还控制给Excel
Set xlBook = nothing
Set xlSheet = nothing
MsgBox "导出到Excel完毕!"
On Error GoTo 0
Exit Function
ErrHandle:
Call gErrList("frmDoubleKeyRpt.ExporToExcelBysql",True)
End Function