VBA Excel - 邮件合并到 PDF 循环遍历数据集

Question

这里是场景。我在 Excel 2016 中使用 VBA 来启动与 Word 的邮件合并。合并的数据源是当前 Excel 文档中的电子表格。该例程为数据集的每次迭代生成一个单独的合并文档。

当我遍历数据集时，会创建一个新的合并文档并保存为 PDF 文档。

问题 #1：

循环时的例程会创建单独的合并文档。每个合并文档都是可见的，所以如果我遍历 5 个数据集，我会得到 5 个打开的合并文档，每个都有适当的数据集值。但是当另存为 PDF 时，它会一遍又一遍地保存第一个合并文档。

在我的代码中，“另存为 PDF”部分会根据数据集中的字段生成一个唯一的文件名，并且可以正常工作。每个保存的 PDF 都有相应的文件名，但实际文件是第一个反复合并的文档。

如何获得将第一个合并文档保存为 PDF 的例程，然后继续进行下一次迭代？

问题 #2：

当例程循环并创建独立的合并文档时，我该如何关闭新创建的单词合并文档？

现有代码：

z = 0
For z = 0 To xCount - 1

lb2_selected = "''" + lb2_array(0, z) + "''"

addr_query = "sp_address_filter '" + lb2_selected + "','" + lb1_selected + "','','" + lb3_selected + "','',''"
'MsgBox (addr_query)

Set rs = conn.Execute(addr_query)

'Clear any existing data from Sheet2
Worksheets("Sheet2").Range("A1:Z10000").Clear

'Load new iteration of data into Sheet2
With rs
    For h = 1 To .Fields.Count
        Sheet2.Cells(1, h) = .Fields(h - 1).Name
        Sheet2.Cells(1, h).Font.Bold = True

    Next h
End With

If Not rs.EOF Then
Sheets(2).Range("A2").CopyFromRecordset rs
End If
rs.Close

'Set value for filename
lb2_array_value = lb2_array(1, z)


Dim wd As Object
Dim wdocSource As Object

Dim strWorkbookName As String

Set wd = CreateObject("Word.Application")

    Set wdocSource = wd.Documents.Open("c:\users\john\documents\LabelPage3.docx")

    strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name

    wdocSource.MailMerge.MainDocumentType = wdFormLetters

    wdocSource.MailMerge.OpenDataSource _
            Name:=strWorkbookName, _
            AddToRecentFiles:=False, _
            Revert:=False, _
            Format:=wdOpenFormatAuto, _
            Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
            SQLStatement:="SELECT * FROM `Sheet2$`"

    With wdocSource.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        .Execute Pause:=False
    End With

    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        "C:\users\john\documents\labels\" + lb2_array_value + ".pdf", _
        ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False

    wd.Visible = True

    wdocSource.Close SaveChanges:=False
    Set wdocSource = Nothing
    Set wd = Nothing

Next z

Answer 1

您当前的设置出现了几个问题。考虑以下调整：

1. MS WORD 对象：ActiveDocument 是 MS Word 对象库的一部分，而不是 Excel。通过不使用 Word.Application 对象对其进行限定，您假设它适用于 Excel。因此，相应地对其进行限定：wd.ActiveDocument。就我而言，这样做会无限期挂起 Excel 而不会出错。

2. 早期绑定 由于没有声明任何 Word 常量，因此您似乎已检查了对 MS Word 对象库的 VBA 引用。因此，请勿将后期绑定调用与早期绑定调用混用：

   更改以下内容：

   Dim wd As Object
   Dim wdocSource As Object
   
   ...
   
   Set wd = CreateObject("Word.Application")
   

   到下面：

   Dim wd As Word.Application
   Dim wdocSource As Word.Document
   
   ...
   
   Set wd = New Word.Application
   

3. 循环过程：将您的 Word 对象分配放在循环之外，因为只有文档需要在循环内设置和取消设置。并使用Application.Quit 方法有效地关闭对象。

   Dim wd As Word.Application
   Dim wdocSource As Word.Document
   
   ...
   
   Set wd = New Word.Application
   wd.Visible = True
   
   For z = 0 To xCount - 1
        ... ' SHEET QUERY PROCESS
   
        Set wdocSource = wd.Documents.Open("c:\users\john\documents\LabelPage3.docx")
   
        ... ' MAIL MERGE PROCESS
   
        wdocSource.Close SaveChanges:=False
        Set wdocSource = Nothing
   Next z
   
   wd.Quit False
   Set wd = Nothing
   

4. WITH BLOCK：为了便于阅读，请始终将With...End With 块用于MailMerge 进程：

   With wdocSource.MailMerge
       .MainDocumentType = wdFormLetters
   
       .OpenDataSource _
           Name:=strWorkbookName, _
           AddToRecentFiles:=False, _
           Revert:=False, _
           Format:=wdOpenFormatAuto, _
           Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
           SQLStatement:="SELECT * FROM `Sheet2$`"
   
       .Destination = wdSendToNewDocument
       .SuppressBlankLines = True
       With .DataSource
           .FirstRecord = wdDefaultFirstRecord
           .LastRecord = wdDefaultLastRecord
       End With
       .Execute Pause:=False
   End With
   

5. 错误处理：作为最佳实践，将整个进程包装在错误处理中，尤其是销毁对象，因为导致运行时错误的代码将使对象作为后台进程运行。

   Public Sub RunMailMerge()
   On Error GoTo ErrHandle
   
       ...       
   
   ExitHandle:
       wdocSource.Close SaveChanges:=False
       Set wdocSource = Nothing
   
       wd.Quit False
       Set wd = Nothing
       Exit Sub
   
   ErrHandle:
       MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
       Resume ExitHandle    
   End Sub