vb6, dot, word, document, append document, 使用word範本匯出word文件檔, 匯出Table, 將數個Word檔合併成一個Word檔

clsGenWordOfFraudZNotice.cls

Option Explicit

Rem
Rem 此類別程式碼需搭配相應的Word範本檔
Rem

'# Parameters - word document template filename
Public WordDotFilename As String

'# Parameters - bookmark
Public B_CLOSE_DATE As String
Public B_NAME As String
Public B_ADDR_C1 As String
Public B_ADDR_C2 As String
Public B_CASE_NO As String
Public B_DISPUTE_AMT As String
Public B_OTHER_DESC As String
Public B_CHECK1, B_CHECK2, B_CHECK3, B_CHECK4 As Boolean

'#需先設定引用項目：Microsoft Word Object Library (MSWORD.OLB)。此版本是Word 2003。
Private m_WordApp As Word.Application
'Private m_WordDoc As Word.Document

Private Sub Class_Initialize()
    Debug.Print "ON : " & TypeName(Me) & "::Class_Initialize"
    If m_WordApp Is Nothing Then Set m_WordApp = New Word.Application
    'wordApp.Visible = False
End Sub

Sub Class_Terminate()
    Debug.Print "ON : " & TypeName(Me) & "::Class_Terminate"
    If Not m_WordApp Is Nothing Then m_WordApp.Quit
    Set m_WordApp = Nothing
End Sub

Public Sub GenerateWord(doc_filename As String)
    On Error GoTo ErrorHandler
    
    Dim wordDoc As Word.Document
    Set wordDoc = m_WordApp.Documents.Add(WordDotFilename)
    
    With wordDoc
        ' form - label box
        .FormFields("B_CLOSE_DATE").Range = B_CLOSE_DATE ' Format(Now, "yyyy/MM/dd")
        .FormFields("B_NAME").Range = B_NAME ' "藍高飛"
        .FormFields("B_ADDR_C1").Range = B_ADDR_C1 ' "地址前半段區"
        .FormFields("B_ADDR_C2").Range = B_ADDR_C2 ' "地址後半段１２３號"
        .FormFields("B_CASE_NO").Range = B_CASE_NO ' "201512-123456"
        .FormFields("B_DISPUTE_AMT").Range = B_DISPUTE_AMT ' "NTD$10,530"
        .FormFields("B_OTHER_DESC").Range = B_OTHER_DESC ' ""
        ' form - check box
        .FormFields("B_CHECK1").Range = IIf(B_CHECK1, "■", "□")
        .FormFields("B_CHECK2").Range = IIf(B_CHECK2, "■", "□")
        .FormFields("B_CHECK3").Range = IIf(B_CHECK3, "■", "□")
        .FormFields("B_CHECK4").Range = IIf(B_CHECK4, "■", "□")
    End With
    
    wordDoc.SaveAs doc_filename ' output
    
FINALLY:
    ' release resource
    If Not wordDoc Is Nothing Then wordDoc.Close
    Set wordDoc = Nothing
    Exit Sub
    
ErrorHandler:
    MsgBox Err.Description, vbOKOnly + vbCritical, "Error Handler"
    GoTo FINALLY
    
End Sub

clsGenWordOfFraudZNoticeAPPLY.vb

Rem 
Rem 應用前述的自訂類別 clsGenWordOfFraudZNotice 產出Word檔
Rem

Private Sub btnGenWordV2_Click()
    On Error GoTo ErrorHandler

    '# UI
    btnGenWordV2.Enabled = False
    Me.MousePointer = vbHourglass
    
    Dim wordHelper As New clsGenWordOfFraudZNotice
    wordHelper.WordDotFilename = App.Path & "\" & txtDotFilename.Text ' "\爭議款結案通知書範本2.dot"
    
    Dim doc_filename As String
    
    Dim i As Integer
    For i = 0 To 3 ' 測試連續產出共４個 Word 檔
        With wordHelper
            ' form - label box
            .B_CLOSE_DATE = txtCloseDate.Text
            .B_NAME = txtName.Text
            .B_ADDR_C1 = txtAddrC1.Text
            .B_ADDR_C2 = txtAddrC2.Text
            .B_CASE_NO = txtCaseNo.Text
            .B_DISPUTE_AMT = txtDisputeAmt.Text
            .B_OTHER_DESC = txtOtherDesc.Text
            ' form - check box
            .B_CHECK1 = IIf(chkCheck1.Value = 1, True, False)
            .B_CHECK2 = IIf(chkCheck2.Value = 1, True, False)
            .B_CHECK3 = IIf(chkCheck3.Value = 1, True, False)
            .B_CHECK4 = IIf(chkCheck4.Value = 1, True, False)
        End With
            
        doc_filename = App.Path & "\TEST" & i & txtDocFilename.Text
        wordHelper.GenerateWord (doc_filename)
        Debug.Print "GenerateWord → " & doc_filename
    Next
        
    MsgBox "已成功產生Word檔"

FINALLY:
    ' release resource
    
    '# UI
    btnGenWordV2.Enabled = True
    Me.MousePointer = vbDefault
    Exit Sub
    
ErrorHandler:
    MsgBox Err.Description, vbOKOnly + vbCritical, "Error Handler"
    GoTo FINALLY
End Sub

vb6_word_append_documents.bas

Rem
Rem 將數個 Word 檔合併成一個 Word 檔
Rem 此例為部份程式碼
Rem

'## 先寫一下虛擬碼說明
'#  依數筆資料產出數份Word並併在一起
'# ForEach {Quired_Data_List}
'#	GenWordFile -> tmpDoc
'#	IF <is_first_doc>
'#		OpenDoc(tmpDoc) -> targetDoc
'#	Else
'#		targetDoc.InsertFile(tmpDoc)
'# Next
'# 
'# SaveFile ( subjectDoc )
'# subjectDoc.Close

Private Sub btnGenWordV2_Click()
    On Error GoTo ErrorHandler

    '# UI
    btnGenWordV2.Enabled = False
    Me.MousePointer = vbHourglass
    
    Dim wordHelper As New clsGenWordOfFraudZNotice
    wordHelper.WordDotFilename = App.Path & "\" & txtDotFilename.Text ' "\爭議款結案通知書範本2.dot"
    
    Dim wordApp As Word.Application
    Dim wordDoc As Word.Document
    Dim doc_target As String
    Dim doc_filename As String
    
    Set wordApp = New Word.Application

    doc_target = App.Path & "\爭議書合併.doc" '# targetDoc  ============
    
    Dim i As Integer
    For i = 0 To 3 ' 測試連續產出共４個 Word 檔
        With wordHelper
            ' form - label box
            .B_CLOSE_DATE = txtCloseDate.Text
            .B_NAME = txtName.Text
            .B_ADDR_C1 = txtAddrC1.Text
            .B_ADDR_C2 = txtAddrC2.Text
            .B_CASE_NO = txtCaseNo.Text
            .B_DISPUTE_AMT = txtDisputeAmt.Text
            .B_OTHER_DESC = txtOtherDesc.Text
            ' form - check box
            .B_CHECK1 = IIf(chkCheck1.Value = 1, True, False)
            .B_CHECK2 = IIf(chkCheck2.Value = 1, True, False)
            .B_CHECK3 = IIf(chkCheck3.Value = 1, True, False)
            .B_CHECK4 = IIf(chkCheck4.Value = 1, True, False)
        End With
            
        doc_filename = App.Path & "\TEST" & i & txtDocFilename.Text
        wordHelper.GenerateWord (doc_filename) '#	GenWordFile -> tmpDoc
        Debug.Print "GenerateWord → " & doc_filename
        
        '## Append to the target documnet.
        If i = 0 Then '#	IF <is_first_doc>  ============
            ' # Open the target document 
            Set wordDoc = wordApp.Documents.Open(doc_filename)  '#		OpenDoc(tmpDoc) -> targetDoc ============
        Else
            ' # Append Doc
            With wordDoc.Content '#		targetDoc.InsertFile(tmpDoc)  ============
                .Collapse (WdCollapseDirection.wdCollapseEnd) ' 把游標移到後面
                .InsertFile (doc_filename) ' 把word檔插入
                .InsertBreak WdBreakType.wdSectionBreakNextPage ' 再插入分隔設定
            End With
        End If
    Next
            
    wordDoc.SaveAs (doc_target) '# SaveFile ( subjectDoc )  ============
    wordDoc.Close
    wordApp.Quit
            
    MsgBox "已成功產生Word檔"

FINALLY:
    ' release resource
    
    '# UI
    btnGenWordV2.Enabled = True
    Me.MousePointer = vbDefault
    
    Exit Sub
ErrorHandler:
    
    MsgBox Err.Description, vbOKOnly + vbCritical, "Error Handler"
    
    GoTo FINALLY
End Sub

vb6_word_append_documents_2.bas

Rem
Rem 將數個 Word 檔合併成一個 Word 檔
Rem 此例為部份程式碼，
Rem 另一個真實的案例，但移除不重要的部份
Rem

'## 虛擬碼：依數筆資料產出數份Word並併在一起
'# ForEach {Quired_Data_List}
'#	GenWordFile -> tmpDoc
'#	IF <is_first_doc>
'#		OpenDoc(tmpDoc) -> targetDoc ; 開啟 tmpDoc 轉存入 targetDoc。
'#    SaveFile ( targetDoc ) 
'#	Else
'#		targetDoc.InsertFile(tmpDoc)
'# Next
'# 
'# SaveFile ( subjectDoc ) ; 存入 targetDoc。
'# subjectDoc.Close

Private Sub GenerateAuthLetterC1(dot_path As String, letter_date As String, output_dir As String, ByRef rs As ADODB.Recordset)
    Rem 子程序

    On Error GoTo ErrorHandler

    Dim wordHelper As New clsGenWordOfAuthLetterC1
    wordHelper.WordApp = OpenWordApplication() ' init wordHelper
    wordHelper.WordDotFilename = dot_path ' 指定Word 範本檔
    
    Dim wordDoc As Word.Document
    Dim letter_date8 As String ' 輸出目錄中段名稱
    Dim doc_fullname, doc_tempname, doc_dir As String ' 輸出Word檔名, 輸出目錄
    Dim card_no As String
    Dim is_first_row As Boolean
    
    '# 先建立好輸出目錄
    letter_date8 = Replace(letter_date, "/", "") ' 取得：輸出目錄中段名稱
    doc_dir = MakeDirectory(output_dir, letter_date8)
    doc_fullname = doc_dir & "\Auth_Letter_C1_" & letter_date8 & ".doc"
    doc_tempname = doc_dir & "\Auth_Letter_C1_tmp.doc"
    
    ' 開始轉出Word檔
    If rs.RecordCount > 0 Then ' 若有值
        rs.MoveFirst
        is_first_row = True
    End If
    
    While Not rs.EOF ' 若無值直接false
        '# 取參數
        card_no = Trim(rs.fields("ACCT_NBR").value)
        pages = rs.fields("PAGES").value
        
        '# 設定輸出Word參數
        With wordHelper
            ' form - label box
            .B_RPT_DATE = Format(Now, "yyyy/mm/dd")
            .B_LETTER_NAME = rs.fields("LETTER_NAME").value
            .B_LETTER_ADDRESS1 = rs.fields("LETTER_ADDRESS1").value
            .B_LETTER_ADDRESS2 = rs.fields("LETTER_ADDRESS2").value
            .B_LETTER_ADDRESS3 = rs.fields("LETTER_ADDRESS3").value
            .B_LETTER_NAME2 = .B_LETTER_NAME
            .B_LETTER_CARD_NUM = Mid(card_no, 1, 4) & "-XXXX-XXXX-" & Mid(card_no, 13, 4)
        End With
        
        '# 輸出Word檔
        wordHelper.GenerateWord (doc_tempname)
        Debug.Print "GenerateWord → " & "Auth_Letter_C1_" & card_no & "_" & pages & ".doc"

        '## Append to the target documnet.
        If is_first_row = True Then
            ' # Open the target Word document  ' =================
            Set wordDoc = m_WordApp.Documents.Open(doc_tempname)
            wordDoc.SaveAs (doc_fullname)
            is_first_row = False
        Else
            ' # Append the target Word document ' =================
            With wordDoc.Content
                .Collapse (WdCollapseDirection.wdCollapseEnd) ' 把游標移到後面
                .InsertFile (doc_tempname) ' 把word檔插入
                .InsertBreak WdBreakType.wdSectionBreakNextPage ' 再插入分隔設定
            End With
        End If

        'next
        rs.MoveNext
    Wend
    
    wordDoc.SaveAs (doc_fullname) '# Save the target Word document  ============
    wordDoc.Close
    
    ' 刪除暫存檔
    FileSystem.Kill doc_tempname
    
FINALLY:
    ' release resource
    
    Exit Sub
ErrorHandler:
    MsgBox Erl & "GenerateAuthLetterC1 " & err.Description, vbOKOnly + vbCritical, "Error Handler"
    GoTo FINALLY

End Sub

vb6_word_dot_to_doc.vb

' 
' # 使用word範本匯出word文件檔
' # 說明文章：http://relycoding.blogspot.tw/2015/12/how-to-connect-ms-word-to-print-output.html
' # 參考: https://www.youtube.com/watch?v=_p_zQGPwXm4
'
Private Sub Command3_Click()

    ' resource
    Static wordApp As Word.Application
    Static wordDoc As Word.Document

    ' open word document
    Set wordApp = New Word.Application
    wordApp.Visible = False

    Debug.Print "App.Path → "; App.Path
    Set wordDoc = wordApp.Documents.Add(App.Path & "\爭議款結案通知書範本.dot")

    ' set form-fields of word
    With wordDoc
        ' form - label box
        .FormFields("B_CLOSE_DATE").Range = Format(Now, "yyyy/MM/dd")
        .FormFields("B_NAME").Range = "藍高飛"
        .FormFields("B_ADDR_C1").Range = "地址前半段區"
        .FormFields("B_ADDR_C2").Range = "地址後半段１２３號"
        .FormFields("B_CASE_NO").Range = "201512-123456"
        .FormFields("B_DISPUTE_AMT").Range = "NTD$10,530"
        ' form - check box
        .FormFields("B_CHECK1").CheckBox.value = True
        .FormFields("B_CHECK2").CheckBox.value = False
        .FormFields("B_CHECK3").CheckBox.value = True
        .FormFields("B_CHECK4").CheckBox.value = False
    End With

    ' close & exit word
    wordDoc.SaveAs App.Path & "\爭議款結案通知書.doc"
    wordDoc.Close
    wordApp.Quit

    ' release resource
    Set wordDoc = Nothing
    Set wordApp = Nothing

End Sub

vb6_word_dot_to_doc2.vb

' 
' # 使用word範本匯出word文件檔，含Table
'
Private Sub Command1_Click()

    '#需先設定引用項目：Microsoft Word Object Library (MSWORD.OLB)。此版本是Word 2003。
    Static wordApp As Word.Application
    Static wordDoc As Word.Document
    
    Dim DotFilename, Docfilename As String
    
    Debug.Print "App.Path → "; App.Path
    DotFilename = App.Path & "\表格控制練習.dot"
    Docfilename = App.Path & "\表格控制練習結果.doc"
    
    Set wordApp = New Word.Application
    Set wordDoc = wordApp.Documents.Add(DotFilename)
    'wordApp.Visible = False
    
    With wordDoc
        ' form - label box
        .FormFields("B_TEXT1").Range = "[[我是由程式指定的哦]]"
    End With
    
    Dim tmpTable As Table
    Dim tmpRow As Row
    
    Set tmpTable = wordDoc.Tables(1) ' 此Array索引由1開始
    
    Set tmpRow = tmpTable.Rows.Add
    tmpRow.Cells(1).Range = "AAA"
    tmpRow.Cells(2).Range = "BBB"
    tmpRow.Cells(3).Range = "12345.678"
    
    Set tmpRow = tmpTable.Rows.Add
    tmpRow.Cells(1).Range = "CCC"
    tmpRow.Cells(2).Range = "DDD"
    tmpRow.Cells(3).Range = "66888.9999"
    
    wordDoc.SaveAs Docfilename ' output
    wordDoc.Close
    wordApp.Quit
    
    MsgBox "已成功產生Word檔：" & Docfilename

    ' release resource
    Set wordDoc = Nothing
    Set wordApp = Nothing
    
End Sub