时间戳

首页 > 解决方案 > VBA Excel - 邮件合并到 PDF 循环遍历数据集

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

问题描述

这是场景。我在 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

标签： excelvbafor-looppdfmailmerge

解决方案

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

  1. MS WORD OBJECT：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

推荐阅读