Private Sub docout_Click() '匯出WORD按鈕
If rs1.RecordCount < 1 Then
MsgBox "匯出失敗，當前串列中沒有記錄!"
outstate1.Visible = False
Exit Sub
End If
On Error GoTo not_installword '當沒裝word軟體時的出錯處理
If MsgBox(Chr(13) + "是否將當前串列中的資料匯出為WORD資料？ ", vbQuestion + vbYesNo) = vbNo Then Exit Sub
Dim wdApp As Word.Application '定義word變數
Dim wdDoc '定義word檔案變數
Dim wdTable '定義WORD表格變數
Dim FieldLen() '存放欄位長度值
Dim FieldLen1 As Integer '存放每列的最大寬度
Dim FieldValue As String
Dim iRow, iCol As Integer
Dim iRowCount, iColCount As Integer '存放行數、列數值
main.Enabled = False
outstate1.Visible = True '顯示匯出狀態
outstate1.Caption = "正在匯出，請稍后..."
With rs1
.MoveLast
iRowCount = .RecordCount + 2 '記錄總數
iColCount = .Fields.Count '欄位總數
.MoveFirst
End With
'重新定義列數
ReDim FieldLen(iColCount)
'添加一個word檔案及表
Set wdApp = New Word.Application
wdApp.Documents.Add '新建Word 檔案
Set wdTable = wdApp.Selection.Tables.Add(wdApp.Selection.Range, iRowCount + 1, iColCount, wdWord9TableBehavior, wdAutoFitFixed)
With rs1
'讀取標題寬度作為列寬初始值
For iCol = 1 To iColCount
FieldLen(iCol) = LenB(StrConv(.Fields(iCol - 1).Name, vbFromUnicode))
Next iCol
For iRow = 1 To iRowCount
For iCol = 1 To iColCount
'讀取欄位值，回傳為文本型
If .Fields(iCol - 1).Value <> "" Then
If .Fields(iCol - 1).Type = 10 Then
FieldValue = Trim(.Fields(iCol - 1).Value)
Else
FieldValue = CStr(.Fields(iCol - 1).Value)
End If
Else
FieldValue = " "
End If
Select Case iRow
Case 1
'第一行為標題行，在后面設定
Case 2 '在第二行插入欄位名
wdTable.Cell(iRow, iCol).Range.InsertAfter (.Fields(iCol - 1).Name)
'設定欄位名居中
wdTable.Cell(iRow, iCol).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
'設定字體為粗體
wdTable.Cell(iRow, iCol).Range.Font.Bold = wdToggle
Case Else '從第三行開始插入記錄
'計算欄位值長度，回傳值的單位是位元組長度
FieldLen1 = LenB(StrConv(FieldValue, vbFromUnicode))
'自動設定表格列寬
If FieldLen(iCol) < FieldLen1 Then
'表格列寬等于較長欄位長
wdTable.Columns(iCol).PreferredWidth = 8 * FieldLen1 'Word表
'陣列Fieldlen(iCol)中存放最大欄位長度值
FieldLen(iCol) = FieldLen1
Else
'表格列寬等于當前欄位寬度
wdTable.Columns(iCol).PreferredWidth = 8 * FieldLen(iCol)
End If
'向表單元格中寫入欄位值
wdTable.Cell(iRow, iCol).Range.InsertAfter (FieldValue)
'設定單元格中的字居中
wdTable.Cell(iRow, iCol).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
End Select
DoEvents
Next iCol
If iRow > 2 Then
If Not .EOF Then .MoveNext
End If
DoEvents
outstate1.Caption = "正在匯出，完成: " + CStr(Int(100 * iRow / iRowCount)) + "%" '顯示匯出進度
Next iRow
'添加年月日
wdTable.Cell(iRowCount + 1, 1).Range.InsertAfter (Format$(Now, "yyyy年mm月dd日")) '在最后一行后加是年月日
wdTable.Rows(iRowCount + 1).Cells.Merge '合并最后一行
wdTable.Cell(iRowCount + 1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
wdTable.Rows(1).Cells.Merge '合并第一行表格
If usetype = "系統管理員" Then
wdTable.Cell(1, 1).Range.InsertAfter ("標題名") '合并以后插入標題
Else
wdTable.Cell(1, 1).Range.InsertAfter (usepart & "標題名") '合并以后插入標題
End If
wdTable.Cell(1, 1).Range.Font.Bold = wdToggle '設定標題為粗體
wdTable.Cell(1, 1).Range.Font.Size = 14 '設定標題為14號字體
wdTable.Cell(1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter '設定標題居中
wdApp.Selection.Tables(1).Rows.Alignment = wdAlignRowCenter '設定表格居中
.MoveFirst
wdApp.Visible = True '顯示Word表格
Set wdApp = Nothing '交還控制給Word
End With
outstate1.Visible = False
main.Enabled = True
Exit Sub
not_installword: '當電腦沒裝word時的處理
MsgBox "匯出錯誤！請檢查電腦是否裝有不低于Word2000版本的Word軟體！" & Chr(13) & Chr(10) & "然后檢查一下出錯處的記錄是否有問題！"
outstate1.Visible = False
main.Enabled = True
End Sub
---------------------
作者：limshirley
來源：CSDN
原文：https://blog.csdn.net/limshirley/article/details/70210425
著作權宣告：本文為博主原創文章，轉載請附上博文鏈接！
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/33334.html
標籤：VB基礎類
下一篇：VBA，賦值給陣列，陣列顯示空值