如何从 Excel 工作表打开 Word MailMerge 的数据源

Question

I am trying to automate the creation of a word document using the OpenDataSource from MailMerge and using as source a worksheet where previously the data was saved.

The problem is that everytime the wdocSource.MailMerge.OpenDataSource is called the excel pauses with the execution. The process WINWORD.EXE is running but Excel doesn't continue as it were waiting for something to happen and I have to kill the process to make it respond.

I checked these questions but I cannot make it work:

Mailmerge from Excel using Word template VBA

Executing Word Mail Merge

Running a MS Word mail merge from excel

Const sTempSourceSheet = "TempSourceSheet"

Creating worksheet source

Sub PrintArray(Data, SheetName, StartRow)
    Dim Destination As range
    Set Destination = range("A" & StartRow)
    Set Destination = Destination.Resize(1, UBound(Data))
    Destination.FormulaR1C1 = Data
End Sub

''''''''''''''''''''''''''''''''''''''''
' SaveSourceSheet
Public Sub SaveSourceSheet(cols() As String, arr() As String)
On Error GoTo error
    Dim ws As Worksheet

    With ActiveWorkbook
        .Sheets.Add(After:=.Sheets(.Sheets.count)).Name = sTempSourceSheet
    End With

    PrintArray cols, sTempSourceSheet, 1
    PrintArray arr, sTempSourceSheet, 2

done:
    Exit Sub

error:
    With ActiveWorkbook
        .Sheets(sTempSourceSheet).Delete
    End With

    Resume done
End Sub

And the code for runnig the MailMerge

Sub Contract(wordfile As String)
    Dim wd As Object
    Dim wdocSource As Object
    Dim excelfile As String
    Dim strWorkbookName As String
    excelfile = ThisWorkbook.path & "\" & ThisWorkbook.Name
    On Error Resume Next
    Set wd = GetObject(, "Word.Application")
    If wd Is Nothing Then
    Set wd = CreateObject("Word.Application")
    End If
    On Error GoTo 0

    Set wdocSource = wd.Documents.Open(wordfile)

    wdocSource.MailMerge.MainDocumentType = wdFormLetters

    wdocSource.MailMerge.OpenDataSource Name:= _
    excelfile, 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=" & excelfile & ";" & _
    "Mode=Read;Extended Properties=" & _
    "HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";" _
    , SQLStatement:="SELECT * FROM `TempSourceSheet$`", SQLStatement1:="", SubType:= _
    wdMergeSubTypeAccess

    With wdocSource.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
    With .DataSource
        .FirstRecord = wdDefaultFirstRecord
        .LastRecord = wdDefaultLastRecord
    End With
    .Execute Pause:=False
    End With

    wd.visible = True
    wdocSource.Close SaveChanges:=False

    Set wdocSource = Nothing
    Set wd = Nothing
End Sub

Any idea?

update

After the changes proposed by @macropod I still have some issues:

In the line .OpenDataSource word shows this message:

Any of the options throws an error:

I checked and the Excel file is present and contains a worksheet with the proper name.

Answer 1

« The problem is that everytime the wdocSource.MailMerge.OpenDataSource is called the excel pauses with the execution. The process WINWORD.EXE is running but Excel doesn't continue as it were waiting for something to happen and I have to kill the process to make it respond. »

That indicates that the document you're trying to open is probably already a mailmerge main document and the code is waiting for you to respond to the SQL query Word produces when opening such documents.

Alternatively, if the document contains auto macros, it could be waiting for a user response.

Your code also contains:

ReadOnly:=False, LinkToSource:=True

which should be:

ReadOnly:=True, LinkToSource:=False

I'd also suggest changing the provider, to:

Microsoft.ACE.OLEDB.12.0

Try the following code:

Sub Contract(wordfile As String)
Dim wdApp As Object, wdDoc As Object
Dim StrMMSrc As String: StrMMSrc = ActiveWorkbook.FullName
If Dir(wordfile) = "" Then
  MsgBox "Cannot find:" & vbCr & wordfile, vbExclamation
  Exit Sub
End If
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
  Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
With wdApp
  .Visible = True
  .WordBasic.DisableAutoMacros
  .DisplayAlerts = 0 ' wdAlertsNone
  Set wdDoc = .Documents.Open(wordfile)
  With wdDoc
    With .MailMerge
      .MainDocumentType = wdFormLetters
      .Destination = wdSendToNewDocument
      .SuppressBlankLines = True
      .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 `TempSourceSheet$`", SubType:=wdMergeSubTypeAccess
      With .DataSource
        .FirstRecord = wdDefaultFirstRecord
        .LastRecord = wdDefaultLastRecord
      End With
      .Execute Pause:=False
    End With
    .Close SaveChanges:=False
  End With
End With
Set wdDoc = Nothing: Set wdApp = Nothing
End Sub