邮件合并字段替换

Question

现在我正在开发一个VBA中的Word加载项，它取代了Word本身内部的标准邮件合并工具。我这样做是因为公司需要在主题行中添加额外的信息，我认为他们可以更好地使用一个简单的UI，因为这个工具不会被专家使用。

到目前为止，我设法阅读带有数据的Excel电子表格并检索它们，但我不明白如何用从中读取的值替换模板中的MailMerge字段，有人可以帮助我吗？

这是我到目前为止写的发送功能

Private Sub SendButton_Click()

Dim toColumn As String, _
    upiColumn As String, _
    subjectLine As String, _
    docID As String, _
    bcc As String, _
    ado As New ADODB.Connection, _
    toColumnNum As Integer, _
    upiColumnNum As Integer, _
    template As String, _
    templateCopy As Document


Dim dataField As MappedDataField



For Each dataField In ActiveDocument.MailMerge.DataSource.MappedDataFields

    Debug.Print "Data Field " + dataField.Value
    ActiveDocument.Fields.Update

Next

' Check if requested fields has been filled '
' To '
With Me.ToBox
    If .ListIndex < 0 Then
        MsgBox "No To column selected"
        Exit Sub
    Else
        toColumn = CStr(.Value)
    End If
End With

' To '
With Me.BccBox
        bcc = .Value
End With


' Subject line '
With Me.SubjectLineBox
    If Trim(.Value & vbNullString) = vbNullString Then
        MsgBox "No subject line inserted"
        Exit Sub
    Else
        subjectLine = .Value
    End If
End With

' UPI '
With Me.UPIBox
    If .ListIndex < 0 Then
        MsgBox "No UPI column selected"
        Exit Sub
    Else
        upiColumn = CStr(.Value)
    End If
End With

' DocID '
With Me.DocIDBox
    If Trim(.Value & vbNullString) = vbNullString Then
        MsgBox "No DocID inserted"
        Exit Sub
    Else
        docID = .Value
    End If
End With

Debug.Print "ToCol: " & toColumn & " UPICol: " & upiColumn & " subject: " & subjectLine & " DocID: " & docID

' Find the corresponding column inside the spreadsheet passed in input '
toColumnNum = GetHeaderColumn(inputFile, toColumn)
upiColumnNum = GetHeaderColumn(inputFile, upiColumn)

Debug.Print "toColumnNum " & toColumnNum & " upiColumnNum " & upiColumnNum

' Open the input file '
With ado
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & inputFile & "';" & "Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1;"";"
End With

' Retrieve the rows '
strQuery = "SELECT * FROM [Sheet1$]"
Set rs = ado.Execute(strQuery)

' Iterate over the rows in the document '
Do While Not rs.EOF

        'Initialize Word'
        Set outlookApp = CreateObject("Outlook.Application")

        'Merge'
        Set olkMsg = outlookApp.CreateItem(olMailItem)
            olkMsg.Body = ""

        'Set olkEditor = olkMsg.GetInspector.WordEditor
        'Set olkDoc = olkIns.WordEditor

        ' Retrieve name of ActiveDocument
        template = ActiveDocument.Name

        ' Test if Activedocument has previously been saved
        If ActiveDocument.Path = "" Then

            ' If not previously saved
            MsgBox "The current document must be saves at least once."

            Exit Sub

        Else
            ' If previously saved, create a copy
            Set templateCopy = Documents.Add(ActiveDocument.FullName)

            For Each mergeField In templateCopy.MailMerge.Fields
                Debug.Print mergeField.Code

                Dim tmpFieldName As String
                tmpFieldName = Split(mergeField.Code, " ")(2)

                For i = 0 To rs.Fields.Count - 1
                    If StrComp(rs.Fields(i).Name, tmpFieldName) = 0 Then
                        Debug.Print rs.Fields(i).Name, rs.Fields(i).Value

                        mergeField = rs.Fields(i).Value

                    End If
                Next
            Next

            With olkMsg
                .BodyFormat = olFormatHTML
                .To = rs.Fields(toColumnNum).Value
                .bcc = bcc
                .Subject = subjectLine & " (UPI=" & rs.Fields(upiColumnNum).Value & ") (DocID=" & docID & ")"
                .HTMLBody = templateCopy.Content
                .Display
            End With


        End If
  rs.MoveNext
Loop
rs.Close

Set olkIns = Nothing
Set olkDoc = Nothing
Set wrdDoc = Nothing
lngRow = lngRow + 1

Set excApp = Nothing
wrdApp.Quit False
Set wrdApp = Nothing
Set wrdRng = Nothing
Set wrdFld = Nothing
Set wrdSel = Nothing
Set olkMsg = Nothing
Set olkRcp = Nothing
Set olkDoc = Nothing
Set olkSel = Nothing

End Sub