Mail Merge - Create PDF files and Send outlook Mail with VBA Code

Option Explicit

Sub ExporttoPDF()

    

    ' Variable Declaration

    Dim Counter As Long

    Dim LastCounter As Long

    Dim Starttime As Date

    Dim endtime As Date

    Dim Duration As Date

    Dim MsgAns As String

    

    ' Getting Start Time of Macro

    Starttime = Now

    

    'Making Sure Preview button is pressed on mailing tab

    Application.ScreenUpdating = True

    ActiveDocument.MailMerge.ViewMailMergeFieldCodes = Not wdToggle

    ActiveDocument.MailMerge.ViewMailMergeFieldCodes = wdToggle

    

    ' Set Active Record to First Record

    ActiveDocument.MailMerge.DataSource.ActiveRecord = wdFirstRecord

    

    ' Loop to get Last Record number of the data

    LastCounter = ActiveDocument.MailMerge.DataSource.RecordCount

    For Counter = 1 To LastCounter

    '   Export to PDF

    

'        ActiveDocument.SaveAs2 ThisDocument.Path & "\Attachment_Base\" _

'            & ActiveDocument.MailMerge.DataSource.DataFields(1).Value _

'            , wdFormatPDF

        

        ActiveDocument.ExportAsFixedFormat _

            OutputFileName:=ThisDocument.Path & "\Attachment_Base\" _

            & ActiveDocument.MailMerge.DataSource.DataFields(1).Value _

            , ExportFormat:=wdExportFormatPDF _

            , OpenAfterExport:=False

            

        ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord

        ' Selecting next Record for next PDF creation

        

    Next Counter

    'turning off Preview button on mailing tab

    ActiveDocument.MailMerge.ViewMailMergeFieldCodes = wdToggle

    

    ThisDocument.Save

    

    ' Getting End Time and calculating the Duration Taken by macro

    Application.ScreenUpdating = False

    endtime = Now

    Duration = endtime - Starttime

    

    ' End of Macro Notification

    Msgbox "Time taken to run this macro " & Format(Duration, "h:m:s") _

            & vbNewLine & "End of Macro." & vbNewLine _

            & "Macro have exported to PDF" _

            , vbInformation, "End of Macro"

             

End Sub

Sub send_oulook_mail()

' Early Binding

'Step 1: declaring the variable

Dim outapp As Outlook.Application

Dim outmail As Variant

Dim LISTOFRANGE As Long

Dim filename As String

Dim Starttime As Date

Dim endtime As Date

Dim Duration As Date

Dim Counter As Long

    Starttime = Now

'Step 2: Loop the Macro

    Application.ScreenUpdating = False

    ActiveDocument.MailMerge.ViewMailMergeFieldCodes = Not wdToggle

    ActiveDocument.MailMerge.ViewMailMergeFieldCodes = wdToggle

    ActiveDocument.MailMerge.DataSource.ActiveRecord = wdFirstRecord

    LISTOFRANGE = ActiveDocument.MailMerge.DataSource.RecordCount

    For Counter = 1 To LISTOFRANGE

'Step 3:Open the Outlook and new mail item

    Set outapp = New Outlook.Application

    Set outmail = outapp.CreateItem(olMailItem)

    

'Step 4: Populate the outlook fields

    With outmail

        .BodyFormat = olFormatHTML

        .To = ActiveDocument.MailMerge.DataSource.DataFields(21).Value

    '   .CC = "Some2@somewhere.com"

        .Subject = "Renewal Intimation- ManipalCigna Health Insurance Co Ltd - " & ActiveDocument.MailMerge.DataSource.DataFields(1).Value

        .HTMLBody = "Dear " & ActiveDocument.MailMerge.DataSource.DataFields(13).Value & ",<BR><br>" _

            & "Thank you for choosing ManipalCigna Health Insurance as your trusted health insurance partner. Your policy bearing no: " _

            & ActiveDocument.MailMerge.DataSource.DataFields(1).Value & " is due for renewal on " _

            & ActiveDocument.MailMerge.DataSource.DataFields(76).Value & ",<BR><br>" _

            & "To renew your policy now" & "<A hREF =" & ActiveDocument.MailMerge.DataSource.DataFields(77).Value & "> click here </a> <br>" _

            & "For any further queries related to renewal: <br><br>" & "Call 1800 102 4465 (toll-free) OR<br>" _

            & "Write to us at " & "<A href = Mailto:renewals@manipalcigna.com> renewals@manipalcigna.com</a> <br>" _

            & "Assuring you of our best services at all times.<br>" _

            & "We look forward to serve you further.<br>" _

            & "Yours sincerely,<br>" & "ManipalCigna Renewal Team<br>" _

            & "(Formerly Known as Cigna TTK Health Insurance Company Ltd)<br>"

         

            filename = ThisDocument.Path & "\Attachment_Base\" & ActiveDocument.MailMerge.DataSource.DataFields(1).Value & ".PDF"

        .Attachments.Add filename

        .Send

    End With

    

'Step 5: End Loop the Macro

    Set outmail = Nothing

        

    ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord

    

    Next Counter

    

'Step 6: Informing User of end of macro

    ActiveDocument.MailMerge.ViewMailMergeFieldCodes = Not wdToggle

    Application.ScreenUpdating = True

    endtime = Now

    Duration = endtime - Starttime

    

    Msgbox "Time taken to run this macro is " & Format(Duration, "h:m:s") _

        & vbNewLine & "Mail Sent. If mail not received contact Anil Devre."

        

End Sub