Public xlApp As New Excel.Application
Public xlBook As Excel.Workbook
Public xlSheet As Excel.Worksheet
Public Function SaveAsExcel(rsErr As ADODB.Recordset, sFileName As String, _
sSheet As String, sOpen As String, ByVal field As String)
Dim fd As field
Dim CellCnt As Integer
Dim i As Integer
Dim fieldArr() As String
Dim t As Integer
fieldArr = Split(field, "|")
On Error GoTo Err_Handler
Screen.MousePointer = vbHourglass
Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets.Add
'獲取字段名
CellCnt = 1
xlSheet.name = sSheet
For Each fd In rsErr.Fields '添加listview標題
xlSheet.Cells(1, CellCnt).value = fieldArr(CellCnt - 1)
xlSheet.Cells(1, CellCnt).Interior.ColorIndex = 33
xlSheet.Cells(1, CellCnt).Font.Bold = True
xlSheet.Cells(1, CellCnt).BorderAround xlContinuous
CellCnt = CellCnt + 1
Next
rsErr.MoveFirst
i = 2
t = 1
Do While Not rsErr.EOF()
CellCnt = 1
For Each fd In rsErr.Fields
If fd.name = "Company_Id" Or fd.name = "Drugs_Id" Then
xlSheet.Cells(i, CellCnt).value = t
Else
xlSheet.Cells(i, CellCnt).NumberFormat = "@"
xlSheet.Cells(i, CellCnt).value = rsErr.Fields(fd.name).value
End If
CellCnt = CellCnt + 1
Next
rsErr.MoveNext
i = i + 1
t = t + 1
Loop
'自動填充
CellCnt = 1
For Each fd In rsErr.Fields
xlSheet.Columns(CellCnt).AutoFit
CellCnt = CellCnt + 1
Next
xlSheet.SaveAs sFileName ' 保存 Worksheet.
xlBook.Close ' 關閉 Workbook
xlApp.Quit ' 關閉 Excel
If sOpen = "YES" Then ' 打開 Excel Workbook
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(sFileName)
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Application.Visible = True
Else
Set xlApp = Nothing '釋放 Excel 對象.
Set xlBook = Nothing
Set xlSheet = Nothing
End If
Err_Handler:
If Err = 0 Then
Screen.MousePointer = vbDefault
Else
MsgBox "未知錯誤！ " & vbCrLf & vbCrLf & Err & ":" & Error & " ", vbExclamation
Screen.MousePointer = vbDefault
End If
End Function