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 ("沒(méi)有記錄!")
Exit Function
End If
'記錄總數
Irowcount = .RecordCount
'字段總數
Icolcount = .Fields.Count
End With
'添加查詢(xún)語(yǔ)句，導入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, 1), .Cells(1, Icolcount)).Interior.Color = vbYellow
'設標題為黑體字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'標題字體加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
'設表格邊框樣式
End With
With xlSheet.PageSetup
.LeftHeader = "" & Chr(10) & "&""楷體_GB2312,常規""&10公司名稱(chēng)：" ' & Gsmc
.CenterHeader = "&""楷體_GB2312,常規""公司人員情況表&""宋體,常規""" & Chr(10) & "&""楷體_GB2312,常規""&10日 期："
.RightHeader = "" & Chr(10) & "&""楷體_GB2312,常規""&10單位："
.LeftFooter = "&""楷體_GB2312,常規""&10制表人："
.CenterFooter = "&""楷體_GB2312,常規""&10制表日期："
.RightFooter = "&""楷體_GB2312,常規""&10第&P頁(yè) 共&N頁(yè)"
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)
'*********************************************************
'* 名稱(chēng)：ExporToExcel
'* 功能：導出數據到EXCEL
'* 用法：ExporToExcel(sql查詢(xún)字符串)
'*********************************************************
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
'添加兩個(gè)Sheet，保證有三個(gè)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", Err.Description, Err.Number, True)
End Function
