Question

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

这将在表格中反映如下：

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

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

我想使用用户表单上的以下按钮运行mailmerge：

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

我为这些字段创建了这个工作模板。

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

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

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

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

（3）此文件应以PDF格式保存。

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

任何帮助都将受到高度赞赏。感谢。

Answer 1

（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）在上述之前，使文档可见（或不可见）

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

（3）我有Adobe 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

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

稍后补充 -

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

和Google for SelectAFile

在船尾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 ===========

Answer 2

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

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

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

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

这是工作代码：

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

我无法强调@donPablo有多少帮助，再次感谢，你刚刚结束了我的周末，我选择了你接受的答案：）

使用Word模板VBA从Excel邮件发送

2 个答案: