vb操作Word[兩個過程]
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
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
來自 “ ITPUB部落格 ” ,連結:http://blog.itpub.net/12639172/viewspace-608291/,如需轉載,請註明出處,否則將追究法律責任。
相關文章
- Visual Basic 6.0(VB6.0)詳細安裝過程
- 記一次uboot升級過程的兩個坑boot
- Python操作WordPython
- Java操作WordJava
- PPT製造個人簡歷的具體操作過程
- zabbix server & proxy部署操作過程Server
- word常規操作
- 使用兩個FIFO完成流水操作
- C#/VB.NET 在Word中新增條碼、二維碼C#
- C#/VB.NET 新增多行文字水印到Word文件C#
- C#/VB.NET 實現Word和ODT文件相互轉換C#
- Word的相關操作
- 關於Entity Freamwork 儲存過程操作儲存過程
- 使用python遠端操作linux過程解析PythonLinux
- 兩個棧實現佇列操作佇列
- MySQL兩階段提交過程原理簡述MySql
- 為什麼man page標題上有兩個 DATE(1)的追蹤過程
- word字型放大怎麼操作?
- 兩個單位方向向量夾角的餘弦值推導過程【遙感】
- 使用CoordinatorLayout過程中遇到的兩個問題以及淺析CoordinatorLayout工作機制
- SQL 儲存過程裡呼叫另一個儲存過程SQL儲存過程
- 輕量ORM-SqlRepoEx (五) 儲存過程操作ORMSQL儲存過程
- 伺服器硬碟掉了兩塊的解決過程伺服器硬碟
- 個性化資料夾圖示(VB)
- C# / VB.NET 在Word中嵌入多媒體(視訊、音訊)檔案C#音訊
- 如何建立一個使用者、授權操作k8s叢集的過程?K8S
- laravel建立一個儲存過程Laravel儲存過程
- Managed C++: Another VB, or VB.NET, or WhateverC++
- python操作word、pdf問題彙總Python
- python-docx操作word文件詳解Python
- 手撕一個spirng IoC的過程
- 一個技術的成長過程
- PR一個 composer包過程記錄
- 儲存有兩塊硬碟離線恢復資料的過程硬碟
- 計算機工作兩年,我決定考研的思考過程計算機
- 透過反射對比兩個物件是否相等反射物件
- C# 讀取Word文字框中的文字、圖片和表格(附VB.NET程式碼)C#
- 一個專案 兩個cgo依賴編譯不通過Go編譯
- WPS 使用宏操作 word裡面的所有表