VBA Excel - 邮件合并到 PDF 循环遍历数据集
VBA Excel - Mail Merge to PDF Looping through datasets
场景如下。我在 Excel 2016 年使用 VBA 启动与 Word 的邮件合并。合并的数据源是当前 Excel 文档中的电子表格。该例程为数据集的每次迭代生成一个单独的合并文档。
当我遍历数据集时,会创建一个新的合并文档并将其另存为 PDF 文档。
问题 #1:
例程循环创建单独的合并文档。每个合并文档都是可见的,所以如果我循环遍历 5 个数据集,我会得到 5 个打开的合并文档,每个都有适当的数据集值。但是当保存为 PDF 时,它会一遍又一遍地保存第一个合并文档。
在我的代码中,"Save As 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
您当前的设置出现了几个问题。考虑以下调整:
MS WORD 对象:ActiveDocument
是 MS Word 对象库的一部分,而不是 Excel。通过不使用 Word.Application 对象限定它,您假设它用于 Excel。因此,相应地限定它:wd.ActiveDocument
。在我这边,这样做会无限挂起 Excel 而不会出错。
EARLY BINDING 由于声明了 none 个 Word 常量,因此您似乎有一个 VBA 对 MS Word 对象的引用图书馆检查了。因此,不要将后期绑定与早期绑定调用混合使用:
更改以下内容:
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
循环过程:将您的 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
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
错误处理:作为最佳实践,将整个过程包装在错误处理中,尤其是销毁对象,因为导致运行时错误的代码将留下对象运行 作为后台进程。
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
场景如下。我在 Excel 2016 年使用 VBA 启动与 Word 的邮件合并。合并的数据源是当前 Excel 文档中的电子表格。该例程为数据集的每次迭代生成一个单独的合并文档。
当我遍历数据集时,会创建一个新的合并文档并将其另存为 PDF 文档。
问题 #1:
例程循环创建单独的合并文档。每个合并文档都是可见的,所以如果我循环遍历 5 个数据集,我会得到 5 个打开的合并文档,每个都有适当的数据集值。但是当保存为 PDF 时,它会一遍又一遍地保存第一个合并文档。
在我的代码中,"Save As 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
您当前的设置出现了几个问题。考虑以下调整:
MS WORD 对象:
ActiveDocument
是 MS Word 对象库的一部分,而不是 Excel。通过不使用 Word.Application 对象限定它,您假设它用于 Excel。因此,相应地限定它:wd.ActiveDocument
。在我这边,这样做会无限挂起 Excel 而不会出错。EARLY BINDING 由于声明了 none 个 Word 常量,因此您似乎有一个 VBA 对 MS Word 对象的引用图书馆检查了。因此,不要将后期绑定与早期绑定调用混合使用:
更改以下内容:
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
循环过程:将您的 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
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
错误处理:作为最佳实践,将整个过程包装在错误处理中,尤其是销毁对象,因为导致运行时错误的代码将留下对象运行 作为后台进程。
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