Here is the whole code. THE datafields from the mailmerge code works fine for the EmailTo field, just not ReplyRecipients
The code is a merge of 2 macros I have used in the past, but seems to work ok, except for this function.
Sub PDF_Save_and_Email_FINAL()
Application.ScreenUpdating = False
Dim StrFolder As String, DocName As String, PDFFile As String, MainDoc As Document, i As Long, j As Long, EmailTo As String, EmailSubject As String, PDFUpload As String
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & "\"
DocName = InputBox("DocumentName")
EmailSubject = DocName
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
On Error Resume Next
For i = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("LastName")) = "" Then Exit For
'below line '
'StrFolder = .DataFields("Folder") & "\"
PDFFile = .DataFields("FirstName") & " " & .DataFields("LastName") & " - " & DocName
EmailTo = .DataFields("StudentNumber")
End With
.Execute Pause:=False
If Err.Number = 5631 Then
Err.Clear
GoTo NextRecord
End If
For j = 1 To Len(StrNoChr)
PDFFile = Replace(PDFFile, Mid(StrNoChr, j, 1), "_")
Next
PDFFile = Trim(PDFFile)
With ActiveDocument
'Add the name to the footer
'.Sections(1).Footers(wdHeaderFooterPrimary).Range.InsertBefore StrName
'.SaveAs FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs FileName:=StrFolder & PDFFile & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
PDFUpload = StrFolder & PDFFile & ".pdf"
End With
'Create an Outlook object and new mail message
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
'Display email and specify To, Subject, etc
With OutlookMail
EmailTo = .DataFields("StudentNumber")
ReplyToTeachers = .DataFields("Teacher")
.Display
.To = EmailTo
.Subject = EmailSubject
.Attachments.Add PDFUpload
.ReplyRecipients.Add ReplyToTeachers
If DisplayEmail = False Then
.send
Else
'.send
End If
End With
NextRecord:
Next i
End With
End With
Application.ScreenUpdating = True
End Sub