VB匯出word文件
阿新 • • 發佈：2019-01-26
Private Sub docout_Click() '匯出WORD按鈕
If rs1.RecordCount < 1 Then
MsgBox "匯出失敗，當前列表中沒有記錄!"
outstate1.Visible = False
Exit Sub
End If
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
iRowCount = .RecordCount + 2 '記錄總數
iColCount = .Fields.Count '欄位總數
.MoveFirst
End With
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 '設定表格居中
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