使用 Word 模板 VBA 从 Excel 进行邮件合并

Mailmerge from Excel using Word template VBA

提问by CaptainABC

I have created a Userform where you can flag records as "In Progress", "Completed", and "Not Completed".

我创建了一个用户表单，您可以在其中将记录标记为“进行中”、“已完成”和“未完成”。

This will reflect on the sheet as below:

这将反映在工作表上，如下所示：

Records marked as "In Progress" will have the letter "P" in the status column. Records marked as "Completed" will have the letter "Y" in the status column. Records marked as "Not Completed" will have the letter "N" in the status column.

标记为“进行中”的记录将在状态栏中显示字母“P”。标记为“已完成”的记录将在状态栏中显示字母“Y”。标记为“未完成”的记录将在状态栏中显示字母“N”。

DataSheet http://im39.gulfup.com/VZVxr.png!

数据表 http://im39.gulfup.com/VZVxr.png！

I want to run a mailmerge using the below buttons on the user form:

我想使用用户表单上的以下按钮运行邮件合并：

Userform http://im39.gulfup.com/98isU.png!

用户表单 http://im39.gulfup.com/98isU.png！

I have created this work template for the fields.

我已经为这些领域创建了这个工作模板。

Document http://im39.gulfup.com/4WMLh.png!

文件 http://im39.gulfup.com/4WMLh.png！

This word template file called "MyTemplate" will be in the same directory as the excel file.

这个名为“MyTemplate”的单词模板文件将与excel文件位于同一目录中。

I am trying to figure out how: (1) Select recepients by filtering the "Status" column, so if the user pressed the first button, it will run the mail merge only for records with "P" in the status column.

我想弄清楚如何：（1）通过过滤“状态”列来选择收件人，因此如果用户按下第一个按钮，它将仅对状态列中带有“P”的记录运行邮件合并。

(2) Run mailmerge without displaying Microsoft Word and only displaying the "Save As" dialog where the user can select where to save the file.

(2) 在不显示 Microsoft Word 的情况下运行 mailmerge，只显示“另存为”对话框，用户可以在其中选择文件的保存位置。

(3) This file should be saved in PDF format.

(3) 此文件应保存为 PDF 格式。

I am running Office 2013 and so far I have the code in bits and pieces and had no luck when trying to run it. I have uploaded the data I am trying to work on: MyBook: https://db.tt/0rLUZGC0MyTemplate: https://db.tt/qPuoZ0D6

我正在运行 Office 2013，到目前为止，我的代码是零零碎碎的，并且在尝试运行它时没有运气。我已经上传了我正在尝试处理的数据：MyBook：https://db.tt/0rLUZGC0 MyTemplate：https://db.tt/qPuoZ0D6

Any help will be highly appreciated. Thanks.

任何帮助将不胜感激。谢谢。

回答by donPablo

(1) What I use is the WHERE clause (on the OpenDataSource, you probably don't need all those options)

(1) 我使用的是 WHERE 子句（在 OpenDataSource 上，您可能不需要所有这些选项）

' setup the SQL
Dim sSQLModel As String, sSQLWhere As String
sSQLModel = " Where  ( AssignLtrType = 'T1' or AssignLtrType = 'T2'  ) ;"

' replace the appropriate value(s)
sSQLWhere = sSQLModel                   ' never replace in the model
sSQLWhere = Replace(sSQLWhere, "T1", mydatavariable)

' open the MERGE
doc.MailMerge.OpenDataSource Name:=sIn, _
    ConfirmConversions:=False, readOnly:=False, LinkToSource:=True, _
    AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
    WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
    Format:=wdOpenFormatAuto, Connection:= _
    "Provider=Microsoft.Jet.OLEDB.4.0;Password="""";" & _
    "User ID=Admin;" & _
    "Data Source=" & sXLSPathFile & ";" & _
    "Mode=Read;Extended Properties=" & _
    "HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";" _
    , SQLStatement:="SELECT * FROM `Detail$`", _
    SQLStatement1:=sSQLWhere, _
    SubType:=wdMergeSubTypeAccess

' do the MERGE
With doc.MailMerge
    .Destination = wdSendToPrinter
    .SuppressBlankLines = True
    With .DataSource
        .FirstRecord = wdDefaultFirstRecord
        .LastRecord = wdDefaultLastRecord
    End With
    .Execute Pause:=False
End With

(2) Prior to the above, make the doc Visible (or Invisible)

（2）在上述之前，使文档可见（或不可见）

' setup the template document
Dim doc As Word.Document
Set doc = wrdApp.Documents.Add(sPathFileTemplate)
wrdApp.Visible = True   ' you can say False

(3) I have Adobe PDF as a Printer (the registry routines were from the web--Google them). Put this prior to OpenDataSource.

(3) 我有 Adob​​e PDF 作为打印机（注册表例程来自网络 - 谷歌他们）。把它放在 OpenDataSource 之前。

' Get current default printer.
SetDefaultPrinter "Adobe PDF"
'Create the Registry Key where Acrobat looks for a file name
CreateNewRegistryKey HKEY_CURRENT_USER, _
    "Software\Adobe\Acrobat Distiller\PrinterJobControl"

'Put the output filename where Acrobat could find it
SetRegistryValue HKEY_CURRENT_USER, _
    "Software\Adobe\Acrobat Distiller\PrinterJobControl", _
    wrdApp.Application.Path & "\WINWORD.EXE", sPathFilePDF

In the SQL, change the tab name from Detail$ to yourTab$ (needs trailing $)

在 SQL 中，将选项卡名称从 Detail$ 更改为 yourTab$（需要尾随 $）

added later--

稍后补充——

Dim sIn As String
sIn = SelectAFile(sInitial:=sDriveSAO, sTitle:=" XLS file")
If (sIn = "" Or sIn = "False") Then Exit Sub

and Google for SelectAFile

和谷歌的 SelectAFile

added 1/22 aft

添加 1/22 后

'   ============= added ===========
Dim xls As Excel.Application   ' for me, because I am running in MSAccess as mdb
Set xls = New Excel.Application
Dim wrdApp As Word.Application  ' for you, to have WORD running
Set wrdApp = New Word.Application
Dim sPathFileTemplate As String
sPathFileTemplate = xls.GetOpenFilename(" docx file,*.docx", , "Template file")
'   ============= added ===========

' changed    you only need one variable
sSQLModel = " Where  ( Status = 'T1'  ) ;"

' changed    replace, possibly with some screen value
sSQLWhere = Replace(sSQLWhere, "T1", "P")

' changed because your tab is named Sheet1
    , SQLStatement:="SELECT * FROM `Sheet1$`", _


'   ============= added ===========
doc.Close False
Set doc = Nothing
wrdApp.Quit False
Set wrdApp = Nothing
'   ============= added ===========

回答by CaptainABC

OK so with a lot of help from @donPablo I finally got a working code which does exactly what I want.

好的，在@donPablo 的大量帮助下，我终于得到了一个工作代码，它完全符合我的要求。

BTW the "Status" in sSQLModel = " Where ( Status = 'T1' ) ;"can be change to any other column heading, but in my case I am filtering based on a value in the column F (Status). The "P" in sSQLWhere = Replace(sSQLWhere, "T1", "P")can also be change to the value been filtered on, but in my case I want all the records containing "P" in the "Status" column.

顺便说一句，“状态”中的“状态”sSQLModel = " Where ( Status = 'T1' ) ;"可以更改为任何其他列标题，但在我的情况下，我根据列 F（状态）中的值进行过滤。“P”中的sSQLWhere = Replace(sSQLWhere, "T1", "P")也可以更改为过滤的值，但在我的情况下，我希望“状态”列中包含“P”的所有记录。

The "Sheet1" in , SQLStatement:="SELECT * FROMSheet1$", _can be changed to the name of the sheet containing the source data for the merge. (Don't forget to include the $ sign at the end of the sheet name.

, SQLStatement:="SELECT * FROMSheet1$ 中的“Sheet1”", _可以更改为包含合并源数据的工作表的名称。（不要忘记在工作表名称的末尾包含 $ 符号。

Before proceeding make sure to load the Microsoft Word Object Library (VBA - Tools - References)

在继续之前，请确保加载 Microsoft Word 对象库（VBA - 工具 - 参考）

And here is the working code:

这是工作代码：

Private Sub CommandButton1_Click()

Dim xls As Excel.Application
Set xls = New Excel.Application
Dim wrdApp As Word.Application
Set wrdApp = New Word.Application
Dim sPathFileTemplate As String
sPathFileTemplate = ThisWorkbook.Path & "\MyTemplate.docx" 'This gets the file called MyTemplate from the same directory
                                                           'in which this excel file is running from

' setup the template document
Dim doc As Word.Document
Set doc = wrdApp.Documents.Add(sPathFileTemplate)
wrdApp.Visible = False   ' Make MS Word Invisible

Dim sIn As String
sIn = ThisWorkbook.FullName 'This Workbook is set the merge data source

' setup the SQL
Dim sSQLModel As String, sSQLWhere As String
sSQLModel = " Where  ( Status = 'T1'  ) ;"

' replace the appropriate value(s)
sSQLWhere = sSQLModel
sSQLWhere = Replace(sSQLWhere, "T1", "P")

' open the MERGE
doc.MailMerge.OpenDataSource Name:=sIn, _
    ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
    AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
    WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
    Format:=wdOpenFormatAuto, Connection:= _
    "Provider=Microsoft.Jet.OLEDB.4.0;Password="""";" & _
    "User ID=Admin;" & _
    "Data Source=" & sXLSPathFile & ";" & _
    "Mode=Read;Extended Properties=" & _
    "HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";" _
    , SQLStatement:="SELECT * FROM `Sheet1$`", _
    SQLStatement1:=sSQLWhere, _
    SubType:=wdMergeSubTypeAccess

' do the MERGE
With doc.MailMerge
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    With .DataSource
        .FirstRecord = wdDefaultFirstRecord
        .LastRecord = wdDefaultLastRecord
    End With
    .Execute Pause:=False
End With


'If you want you can delete this part and proceed to diretly define the
'filename and path below in "OutputFileName"
On Error Resume Next
Dim FileSelected As String
FileSelected = Application.GetSaveAsFilename(InitialFileName:="Export", _
                                         FileFilter:="PDF Files (*.pdf), *.pdf", _
                                         Title:="Save PDF as")
If Not FileSelected <> "False" Then
MsgBox "You have cancelled"
doc.Close False
Set doc = Nothing
wrdApp.Quit False
Set wrdApp = Nothing
Exit Sub
End If

If FileSelected <> "False" Then
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

wrdApp.Application.Options.SaveInterval = False

'Saves Documents as PDF and does not open after saving, you can change OpenAfterExport:=False to True
wrdApp.Application.ActiveDocument.ExportAsFixedFormat OutputFileName:=FileSelected, _
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

doc.Close False
Set doc = Nothing
wrdApp.Quit False
Set wrdApp = Nothing

MsgBox "Done"

End If  ' this EndIf pretains to the SaveAs code above

End Sub

I cannot stress enough how much help was @donPablo, thanks again, you just made my weekend and I am selecting your answer as accepted :)

我不能强调@donPablo 有多大帮助，再次感谢，你刚刚度过了我的周末，我选择你的答案作为接受:)