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

Question

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.

DataSheet 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 !

I have created this work template for the fields.

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

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

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.

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

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

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/0rLUZGC0 MyTemplate: https://db.tt/qPuoZ0D6

Any help will be highly appreciated. Thanks.

Answer 1

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

' 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)

' 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.

' 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 $)

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

added 1/22 aft

'   ============= 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 ===========

Answer 2

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

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.

The "Sheet1" in , SQLStatement:="SELECT * FROM Sheet1$ ", _ 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.

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

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 :)