Public conDb As String
Public Sub exportWordReport(rs As ADODB.Recordset, filePath As String)
Dim WordApp As word.Application
Err.Number = 0
On Error GoTo notloaded
' Set WordApp = GetObject(, "Word.Application")
'notloaded:
' If Err.Number = 429 Then
Set WordApp = CreateObject("Word.Application")
' theError = Err.Number
' End If
WordApp.Visible = True
With WordApp
Set newDoc = .Documents.Add
With .Selection
' .InsertCaption Label, "報表表格"
Dim i, j As Integer
i = 0
j = 0
For i = 1 To rs.Fields.count Step 1
.InsertAfter Text:=rs.Fields(i - 1).Name
If i <> rs.Fields.count Then .InsertAfter Text:=vbTab
Next i
.InsertAfter Text:=vbCr
rs.MoveFirst
While Not rs.BOF And Not rs.EOF 'Worksheets("Sheet1").Range("A1:B10")
For j = 1 To rs.Fields.count Step 1
If IsNull(rs.Fields(j - 1).Value) Then
.InsertAfter " "
Else
.InsertAfter Text:=rs.Fields(j - 1).Value
End If
If j <> rs.Fields.count Then .InsertAfter Text:=vbTab
Next j
.InsertAfter Text:=vbCr
'count = count + 1
'If count Mod rs.Fields.count = 0 Then '2
' .InsertAfter Text:=vbCr
' Else
' .InsertAfter Text:=vbTab
' End If
rs.MoveNext
Wend 'Next
.Range.ConvertToTable Separator:=wdSeparateByTabs
.Tables(1).AutoFormat Format:=wdTableFormatClassic1
'.Select
'.InsertAfter vbCr
' .InsertDateTime "yyyy-mm-dd hh:mm:ss"
End With
newDoc.SaveAs FileName:=filePath
End With
' If theError = 429 Then WordApp.Quit
Set WordApp = Nothing
Exit Sub
notloaded:
MsgBox "無法執行導出Word報表操作," & errMsg, vbCritical, "導出Word報表提示"
End Sub
Public Sub exportFormExcelTable(ByVal sql As String, title As String)
On Error GoTo errlabel
'進行數據轉換
'打開數據庫
'把數據導入EXCEL
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
cn.Open conDb
rs.Open sql, cn, adOpenKeyset, adLockOptimistic '"select * from customers "
If rs.RecordCount > 0 Then
Dim ex As New EXCEL.Application
Dim exbook As New EXCEL.Workbook
Dim exsheet As New EXCEL.Worksheet
Set exbook = ex.Workbooks.Add '添加一個新的BOOK
Set exsheet = exbook.Worksheets("sheet1") '把sheet1作爲當前操作的sheet,添加一個新的SHEET exbook.Worksheets.Add
Dim count As Integer
count = rs.Fields.count - 1
exsheet.Cells(1, count / 2).Value = title
For j = 0 To count Step 1
exsheet.Cells(2, j + 1).Value = rs.Fields(j).Name
Next j
Dim i, k As Integer
i = 3
k = 0
rs.MoveFirst
While (Not rs.EOF And Not rs.BOF)
For k = 0 To count
'ex.Range(Chr(65 + k) & i).Value = rs.Fields(k).Value
ex.Cells(i, k + 1) = rs.Fields(k).Value
Next k
i = i + 1
rs.MoveNext
Wend
'畫表格
With ex
'Range("A2:" & Chr(65 + count) & (rs.RecordCount + 2)).Select
.Range(Cells(2, 1), Cells(rs.RecordCount + 2, count + 1)).Select
.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With .Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'ex.Visible = True
'exsheet.Range("A1:" & Chr(65 + count) & (rs.RecordCount + 2)).Select
exsheet.Range(Cells(1, 1), Cells(rs.RecordCount + 2, count + 1)).Select
.Selection.Copy
End With
rs.Close
cn.Close
Dim word As word.Application
Set word = CreateObject("Word.Application")
With word
.Documents.Add
With .Selection
Dim excelData As Object
Set excelData = word.ActiveDocument.Range(0, 0)
excelData.PasteSpecial
' .Paste 'ExcelTable False, True, False
End With
'.Documents(1).SaveAs "C:/1.doc"
word.Visible = True
End With
Set excelData = Nothing
Set word = Nothing
ex.DisplayAlerts = False
ex.Quit
Set exbook = Nothing
Set exsheet = Nothing
Set ex = Nothing
Else
MsgBox "沒有數據源,無法執行導出Word報表操作!", vbOKOnly, "導出Word報表提示"
End If
Exit Sub
errlabel:
MsgBox "無法執行導出Word報表操作," & errMsg, vbCritical, "導出Word報表提示"
End Sub