访问中的mailmerge vba在一个.xls文件上调用一个选择表弹出窗口，只有一个工作表

Question

该代码应该生成标签，该标签将用于在深水潜水期间收集的标本。

Sub MailMergeSpecimenLabels()
    Dim pathMergeTemplates As String
    Dim pathMergeLabels As String
    Dim pathMergeTemp As String
    Dim outfilename As String
    Dim infilename As String
    Dim templatefilename As String
    Dim msg As String
    
    'Get the word template from the templates folder
    
    pathMergeTemplates = CurrentProject.Path & "\templates\"
    pathMergeLabels = CurrentProject.Path & "\completed\"
    pathMergeTemp = CurrentProject.Path & "\temp\"
            
    'Export the data using a Macro
    
    templatefilename = pathMergeTemplates & "Primary_Specimens.docx"
    infilename = pathMergeTemp & "SpecimenLabels.xls"
    outfilename = pathMergeLabels & "PrimarySpecLabels_" & Format(Now(), "yyyymmddmms") & ".docx"
            
    DoCmd.RunMacro ("ExportPrimarySpecsforLabels")
    
    ' Access has built the .xls file.
    'Now the mail merge doc gets opened
    
        Dim appWord As Object
        Dim docWord As Object
        
        Set appWord = CreateObject("Word.Application")
    
    'Open the template in the templates folder
    
        Set docWord = appWord.Documents.Add(templatefilename, Visible:=False)
        
    'Now we can mail merge without involving the database

        With docWord.MailMerge
            .OpenDataSource Name:=infilename, ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False
            .Destination = 0
            .Execute Pause:=False
        End With
        appWord.ActiveDocument.SaveAs outfilename
        
        msg = "Specimen Labels are generated.  Would you like to open the label file?"
        DoCmd.RunMacro "MarkPrinted"
        Response = MsgBox(msg, Style)
        If Response = 1 Then
            appWord.Documents.Open filename:=outfilename & "", ReadOnly:=False
        End If
        
        appWord.Quit savechanges:=False
        Set docWord = Nothing
        Set appWord = Nothing
        
Finally:
    Exit Sub
    
Hell:
    MsgBox Err.Description & " " & Err.Number, vbExclamation
    
On Error Resume Next
    appWord.Quit savechanges:=False
    Set docWord = Nothing
    Set appWord = Nothing
    Resume Finally
End Sub

当mailmerge.ecute发生时，弹出窗口（我只能查看是否转到任务管理器）会中断代码要求我选择表。我该如何避免这种情况？ .xls文件中只有一个表。

我认为当我重建模板并在设置数据源时在此处找到该精选的表弹出窗口时，我发现了问题，但是它不起作用。

Answer 1

从另一个应用程序运行mailmerge时，您需要禁用用于MailMerge的文档中的任何MailMerge警报 - 杀死该文档中的MailMerge参数 - 然后重新确定代码中的MailMermerge参数。因此：

Sub MailMergeSpecimenLabels()
' Note: this code requires a reference to the Word object model to be set, via Tools|References in the VBE.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, Response As Long
Dim StrMMSrc As String, StrMMDoc As String, StrMMOut As String, StrName As String
Const msg As String = "Specimen Labels are generated.  Would you like to open the label file?"
'Define the files & paths
StrMMDoc = CurrentProject.Path & "\templates\Primary_Specimens.docx"
StrMMSrc = CurrentProject.Path & "\temp\SpecimenLabels.xls"
StrMMOut = CurrentProject.Path & "\completed\PrimarySpecLabels_" & Format(Now(), "yyyymmddmms") & ".docx"

DoCmd.RunMacro ("ExportPrimarySpecsforLabels")

With wdApp
  .Visible = True
  .DisplayAlerts = wdAlertsNone
  Set wdDoc = .Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
  With wdDoc
    With .MailMerge
      .MainDocumentType = wdMailingLabels
      .OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
        LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
        "Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
        SQLStatement:="SELECT * FROM `Sheet1
从另一个应用程序运行mailmerge时，您需要禁用用于MailMerge的文档中的任何MailMerge警报 - 杀死该文档中的MailMerge参数 - 然后重新确定代码中的MailMermerge参数。因此：
"
      .Execute Pause:=False
    End With
    .Close SaveChanges:=False
  End With
  Set wdDoc = Nothing
  .DisplayAlerts = wdAlertsAll
  
  With .ActiveDocument
    .SaveAs Filename:=StrMMOut, FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
    
    DoCmd.RunMacro "MarkPrinted"
    
    Response = MsgBox(msg, vbYesNo)
    If Response = vbYes Then
      .Activate
    Else
      .Close SaveChanges:=False
      wdApp.Quit: Set wdApp = Nothing
    End If
  End With
End With
Application.ScreenUpdating = False
End Sub