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:usersjohndocumentsLabelPage3.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:usersjohndocumentslabels" + 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限定它。应用程序对象，您假设它用于Excel。因此，对其进行相应的限定：wd.ActiveDocument。就我而言，这样做会无限地挂起Excel而不会出错。

2. EARLY BINDING由于没有声明任何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对象赋值置于循环之外，因为只有文档需要在循环中设置和取消设置。并使用应用程序。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:usersjohndocumentsLabelPage3.docx")
   ... ' MAIL MERGE PROCESS
   wdocSource.Close SaveChanges:=False
   Set wdocSource = Nothing
   Next z
   wd.Quit False
   Set wd = Nothing
   

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

   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