VBA Mail Merge to PDF and attach to email body - Code works but need a little help

[pk247]

Hi All,

A while ago I tweaked the code below to attach the mail merged letter as a pdf file to the email with pre-written subject and body (I have edited this out for compliance reasons). It works fine but with a new update in my workplace the pdf files no longer open because of Adobe settings (corrupt file etc.).

I'm sure there's a way around this but I'm just not competent enough to get it to work. Would anyone be able to help me with this please? I'm on Word 2010.



Sub Email_Pdf_as_attachment()
' reference to the Microsoft Office of Outlook Library
' reference to the Microsoft Scripting Runtime
' ensure Z drive folder is set up for pdf files
Dim bOutlookStarted As Boolean
Dim bTerminateMerge As Boolean
Dim intSourceRecord As Integer
Dim objMailItem As Outlook.MailItem
Dim objMerge As Word.MailMerge
Dim objOutlook As Outlook.Application
Dim strMailSubject As String
Dim strMailTo As String
Dim strMailBody As String
Dim strOutputDocumentName As String
Dim savePath As String
bOutlookStarted = False
bTerminateMerge = False
Set objMerge = ActiveDocument.MailMerge
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set objOutlook = CreateObject("Outlook.Application")
bOutlookStarted = True
End If
With objMerge
intSourceRecord = 1
Do Until bTerminateMerge
.DataSource.ActiveRecord = intSourceRecord
If .DataSource.ActiveRecord <> intSourceRecord Then
bTerminateMerge = True
Else
strMailSubject = "Email Subject..." & _
objMerge.DataSource.DataFields("Type_Indicator")
strMailBody = "Dear " & objMerge.DataSource.DataFields("First_Name").Value & " " & _
objMerge.DataSource.DataFields("Last_Name").Value & "," & _
"<p>Please find attached..." & vbNewLine & _
"<p>If you require any further assistance... " & _
"<p>Yours sincerely," & _
"<p>Name..."
strMailTo = objMerge.DataSource.DataFields("Email")
savePath = ActiveDocument.Path
strOutputDocumentName = "Z:\Downloads\" & _
.DataSource.DataFields("First_Name").Value & "_" & _
.DataSource.DataFields("Last_Name").Value & _
"...Access Letter.pdf"
.DataSource.FirstRecord = intSourceRecord
.DataSource.LastRecord = intSourceRecord
.Destination = wdSendToNewDocument
.Execute
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Set objMailItem = objOutlook.CreateItem(olMailItem)
With objMailItem
.BodyFormat = olFormatHTML
.Subject = strMailSubject
.HTMLBody = strMailBody
.To = strMailTo
.Attachments.Add strOutputDocumentName, olByValue, 1
.Save
.Send
End With
Set objMailItem = Nothing
intSourceRecord = intSourceRecord + 1
End If
Loop
End With
If bOutlookStarted Then
objOutlook.Quit
End If
Set objOutlook = Nothing
Set objMerge = Nothing
End Sub


PS If I change the .pdf in "...Access Letter.pdf" to .doc the attachment opens just fine in Word

Thanks in advance for any assistance.

Paul, Ireland

[gmayor]

Looking at it I am surprised that it ever worked. My guess is that the 'pdf' file is in fact a Word document DOCX file, with the wrong extension. (Try renaming it and see if it opens in Word). However you can save the document as DOC/DOCX which you say works then resave that document as PDF before attaching the PDF to the message

You can derive the new name for the PDF from the DOCX name with

strOutputDocumentName = Left(strOutputDocumentName, InStrRev(strOutputDocumentName, Chr(46))) & "pdf"

If the document you are closing with

ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
is the merged document strOutputDocumentName then save it again as PDF before closing. e.g.


ActiveDocument.ExportAsFixedFormat OutputFileName:=strOutputDocumentName, _
ExportFormat:=17, _
OpenAfterExport:=False, _
OptimizeFor:=0, _
Range:=0, From:=1, to:=1, _
Item:=0, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=1, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False


That sounds like it should work, though without your document it is difficult to test it.

If all else fails - see http://www.gmayor.com/ManyToOne.htm in one to one mode. The only proviso is that the data must be in Excel.

[pk247]

Mr Mayor,

You sir, are THE BEST. I added in your edits and the code works perfectly. Thank you for seeing what would have taken me 4-5 hours to figure out.

I have tried to edit the code so that anyone else can make use of it. Thank you very very much Graham Mayor



Sub Email_PDF_ATTACHMENT()
' reference to the Microsoft Office verson # Outlook Library
' reference to the Microsoft Scripting Runtime
' ensure Z drive folder is set up for pdf files
Dim bOutlookStarted As Boolean
Dim bTerminateMerge As Boolean
Dim intSourceRecord As Integer
Dim objMailItem As Outlook.MailItem
Dim objMerge As Word.MailMerge
Dim objOutlook As Outlook.Application
Dim strMailSubject As String
Dim strMailTo As String
Dim strMailBody As String
Dim strOutputDocumentName As String
bOutlookStarted = False
bTerminateMerge = False
Set objMerge = ActiveDocument.MailMerge
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set objOutlook = CreateObject("Outlook.Application")
bOutlookStarted = True
End If
With objMerge
intSourceRecord = 1
Do Until bTerminateMerge
.DataSource.ActiveRecord = intSourceRecord
If .DataSource.ActiveRecord <> intSourceRecord Then
bTerminateMerge = True
Else
strMailSubject = "Type your subject here...... " & _
objMerge.DataSource.DataFields("Type_Indicator") 'This is my mergefield record but you can edit or remove as you like
strMailBody = "Dear " & objMerge.DataSource.DataFields("First_Name").Value & " " & _
objMerge.DataSource.DataFields("Last_Name").Value & "," & _
"<p>Please find attached......" & vbNewLine & _
"<p>......" & _
"<p>Yours sincerely," & _
"<p>Your name......"
strMailTo = objMerge.DataSource.DataFields("Email")
strOutputDocumentName = "Z:\Downloads\" & _
.DataSource.DataFields("First_Name").Value & "_" & _
.DataSource.DataFields("Last_Name").Value & _
" NAME OF FILE.doc"
.DataSource.FirstRecord = intSourceRecord
.DataSource.LastRecord = intSourceRecord
.Destination = wdSendToNewDocument
.Execute
strOutputDocumentName = Left(strOutputDocumentName, InStrRev(strOutputDocumentName, Chr(46))) & "pdf"
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
ActiveDocument.ExportAsFixedFormat
OutputFileName:=strOutputDocumentName, _
ExportFormat:=17, _
OpenAfterExport:=False, _
OptimizeFor:=0, _
Range:=0, From:=1, To:=1, _
Item:=0, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=1, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
Set objMailItem = objOutlook.CreateItem(olMailItem)
With objMailItem
.BodyFormat = olFormatHTML
.Subject = strMailSubject
.HTMLBody = getText(strOutputDocumentName)
.HTMLBody = strMailBody
.To = strMailTo
.Attachments.Add strOutputDocumentName, olByValue, 1
.Save
.Send
End With
Set objMailItem = Nothing
intSourceRecord = intSourceRecord + 1
End If
Loop
End With
If bOutlookStarted Then
objOutlook.Quit
End If
Set objOutlook = Nothing
Set objMerge = Nothing
End Sub


Till the next time,

Paul, Ireland