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