none
word mail merge with PDF attachment to email RRS feed

  • Question

  • Hi there,

    I am using this code from http://www.rondebruin.nl/search.htm , everything works great but i want to use my mailmerge document to the email address i have. can someone please help me with this

    Basically i have word document created a mail merge to pull out the information from excel workbook but i also want to include pdf with the mail merge document to email.

    Private Sub RDB_Outlook_Click()
        Dim StringTo As String, StringCC As String, StringBCC As String
        Dim ShArr() As String, FArr() As String, strDate As String
        Dim myCell As Range, cell As Range, rng As Range, Fname As String, Fname2 As String
        Dim wb As Workbook, sh As Worksheet
        Dim DefPath As String
        Dim olApp As Object
        Dim olMail As Object
        Dim FileExtStr As String

        Dim ToArray As Variant
        Dim CCArray As Variant
        Dim BCCArray As Variant

        Dim StringFileNames As String
        Dim StringSheetNames As String
        Dim FileNamesArray As Variant
        Dim SheetNamesArray As Variant
        Dim I As Long, S As Long, F As Long
        Dim WrongData As Boolean

        If Len(ThisWorkbook.Path) = 0 Then
            MsgBox "This macro will only work if the file is Saved once", 48, "RDBMailPDFOutlook"
            Exit Sub
        End If

        If Me.ProtectContents = True Or ActiveWindow.SelectedSheets.Count > 1 Then
            MsgBox "This macro will not work if the RDBMailOutlook worksheet is " & _
                   "protected or if you have more then sheet selected(grouped)", 48, "RDBMailPDFOutlook"
            Exit Sub
        End If

        'Set folder where we save the temporary files
        DefPath = Application.DefaultFilePath
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If

        'Set reference to Outlook and turn of ScreenUpdating and Events
        Set olApp = CreateObject("Outlook.Application")
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With

        'Set cells with Red interior color to no fill(cells with wrong data)
        Range("A6").ListObject.DataBodyRange.Interior.Pattern = xlNone

        'Set rng to the first column of the table
        Set rng = Me.Range("A6").ListObject.ListColumns(1).Range

        For Each myCell In rng

            'Create mail if "Yes " in column A
            If LCase(myCell.Value) = "yes" Then

                StringTo = "": StringCC = "": StringBCC = ""
                S = 0: F = 0
                Erase ShArr: Erase FArr

                'Set Error Boolean to False
                WrongData = False

                'Check if there are Sheet names in column B

                'If B is empty S = 0 so you not want to send a sheet or sheets as pdf
                If Trim(Me.Cells(myCell.Row, "B").Value) = "" Then S = 0

                'If there are sheet names in the B column S is the number of sheets it add to the Array
                If LCase(Trim(Me.Cells(myCell.Row, "B").Value)) <> "workbook" Then
                    StringSheetNames = Me.Cells(myCell.Row, "B").Value
                    SheetNamesArray = Split(StringSheetNames, Chr(10), -1)

                    For I = LBound(SheetNamesArray) To UBound(SheetNamesArray)
                        On Error Resume Next
                        If SheetNamesArray(I) <> "" Then
                            If SheetExists(CStr(SheetNamesArray(I))) = False Then
                                Me.Cells(myCell.Row, "B").Interior.ColorIndex = 3
                                WrongData = True
                            Else
                                S = S + 1
                                ReDim Preserve ShArr(1 To S)
                                ShArr(S) = SheetNamesArray(I)
                            End If
                        End If
                        On Error GoTo 0
                    Next I
                Else
                    'If you only enter "workbook" in colomn B to mail the whole workbook S = -1
                    S = -1
                End If

                'Check to Mail addresses in column D
                If Trim(Me.Cells(myCell.Row, "D").Value) <> "" Then
                    StringTo = Me.Cells(myCell.Row, "D").Value
                    ToArray = Split(StringTo, Chr(10), -1)
                    StringTo = ""

                    For I = LBound(ToArray) To UBound(ToArray)
                        If ToArray(I) Like "?*@?*.?*" Then
                            StringTo = StringTo & ";" & ToArray(I)
                        End If
                    Next I
                End If

                'Check to Mail addresses in column E
                If Trim(Me.Cells(myCell.Row, "E").Value) <> "" Then
                    StringCC = Me.Cells(myCell.Row, "E").Value
                    CCArray = Split(StringCC, Chr(10), -1)
                    StringCC = ""

                    For I = LBound(CCArray) To UBound(CCArray)
                        If CCArray(I) Like "?*@?*.?*" Then
                            StringCC = StringCC & ";" & CCArray(I)
                        End If
                    Next I
                End If

                'Check to Mail addresses in column F
                If Trim(Me.Cells(myCell.Row, "F").Value) <> "" Then
                    StringBCC = Me.Cells(myCell.Row, "F").Value
                    BCCArray = Split(StringBCC, Chr(10), -1)
                    StringBCC = ""

                    For I = LBound(BCCArray) To UBound(BCCArray)
                        If BCCArray(I) Like "?*@?*.?*" Then
                            StringBCC = StringBCC & ";" & BCCArray(I)
                        End If
                    Next I
                End If

                If StringTo = "" And StringCC = "" And StringBCC = "" Then
                    Me.Cells(myCell.Row, "D").Resize(, 3).Interior.ColorIndex = 3
                    WrongData = True
                End If

                'Check the other files that you want to attach in column H
                If Trim(Me.Cells(myCell.Row, "H").Value) <> "" Then
                    StringFileNames = Me.Cells(myCell.Row, "H").Value
                    FileNamesArray = Split(StringFileNames, Chr(10), -1)

                    For I = LBound(FileNamesArray) To UBound(FileNamesArray)
                        On Error Resume Next
                        If FileNamesArray(I) <> "" Then
                            If Dir(FileNamesArray(I)) <> "" Then
                                If Err.Number = 0 Then
                                    F = F + 1
                                    ReDim Preserve FArr(1 To F)
                                    FArr(F) = FileNamesArray(I)
                                Else
                                    Err.Clear
                                    Me.Cells(myCell.Row, "H").Interior.ColorIndex = 3
                                    WrongData = True
                                End If
                            Else
                                Me.Cells(myCell.Row, "H").Interior.ColorIndex = 3
                                WrongData = True
                            End If
                        End If
                        On Error GoTo 0
                    Next I
                End If

                'Not create the mail if there are Errors in the row (wrong sheet or file names or no mail addresses)
                If WrongData = True Then GoTo MailNot


                'Create PDF and Mail

                'Create Date/time string for the file name
                strDate = Format(Now, "dd-mmm-yyyy hh-mm-ss")

                'Copy the sheet(s)to a new workbook
                If S > 0 Then
                    ThisWorkbook.Sheets(ShArr).Copy
                    Set wb = ActiveWorkbook
                End If

                'You enter only "workbook" in colomn B to mail the whole workbook
                'Use SaveCopyAs to make a copy of the workbook
                If S = -1 Then
                    FileExtStr = "." & LCase(Right(ThisWorkbook.Name, _
                                                   Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, ".", , 1)))
                    Fname2 = DefPath & "TempFile " & strDate & FileExtStr

                    ThisWorkbook.SaveCopyAs Fname2
                    Me.Activate
                    Set wb = Workbooks.Open(Fname2)
                    Application.DisplayAlerts = False
                    wb.Sheets(Me.Name).Delete
                    Application.DisplayAlerts = True
                    If wb.Sheets(1).Visible = xlSheetVisible Then wb.Sheets(1).Select
                End If


                'Now we Publish to PDF
                If S <> 0 Then
                    Fname = DefPath & Trim(Me.Cells(myCell.Row, "C").Value) & _
                          " " & strDate & ".pdf"

                    On Error Resume Next
                    wb.ExportAsFixedFormat _
                            Type:=xlTypePDF, _
                            Filename:=Fname, _
                            Quality:=xlQualityStandard, _
                            IncludeDocProperties:=True, _
                            IgnorePrintAreas:=False, _
                            OpenAfterPublish:=False
                    On Error GoTo 0
                    wb.Close False
                    Set wb = Nothing
                End If

                On Error Resume Next
                Set olMail = olApp.CreateItem(0)
                With olMail
                    .To = StringTo
                    .CC = StringCC
                    .BCC = StringBCC
                    .Subject = Me.Cells(myCell.Row, "G").Value
                    .Body = Me.Cells(myCell.Row, "I").Value
                    If S <> 0 Then .Attachments.Add Fname

                    If F > 0 Then
                        For I = LBound(FArr) To UBound(FArr)
                            .Attachments.Add FArr(I)
                        Next I
                    End If

                    'Set Importance  0 = Low, 2 = High, 1 = Normal
                    If LCase(Me.Cells(myCell.Row, "J").Value) = "yes" Then
                        .Importance = 2
                    End If

                    'Display the mail or send it directly, see cell C3
                    If LCase(Me.Range("C3").Value) = "yes" Then
                        .Display
                    Else
                        .Send
                    End If


                End With

                If S = -1 Then Kill Fname2
                Kill Fname
                On Error GoTo 0

                Set olMail = Nothing

            End If
    MailNot:
        Next myCell

        If LCase(Me.Range("C3").Value) = "no" Then
            MsgBox "The macro is ready and if correct the mail or mails are created." & vbNewLine & _
                   "If you see Red cells in the table then the information in the cells is " & vbNewLine & _
                   "not correct. For example there is a sheet or filename that not exist." & vbNewLine & _
                   "Note: It will not create a Mail of the information in a row with a " & vbNewLine & _
                   "Red cell or cells.", 48, "RDBMailPDFOutlook"
        End If


        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With

        Set olApp = Nothing
    End Sub


    Function SheetExists(wksName As String) As Boolean
        On Error Resume Next
        SheetExists = CBool(Len(ThisWorkbook.Sheets(wksName).Name) > 0)
        On Error GoTo 0
    End Function

    Private Sub BrowseAddFiles_Click()
        Dim Fname As Variant
        Dim fnum As Long

        If ActiveCell.Column = 8 And ActiveCell.Row > 6 Then
            Fname = Application.GetOpenFilename(filefilter:="All Files (*.*), *.*", _
                                                MultiSelect:=True)
            If IsArray(Fname) Then
                For fnum = LBound(Fname) To UBound(Fname)
                    If fnum = 1 And ActiveCell.Value = "" Then
                        ActiveCell.Value = ActiveCell.Value & Fname(fnum)
                    Else
                        If Right(ActiveCell, 1) = Chr(10) Then
                            ActiveCell.Value = ActiveCell.Value & Fname(fnum)
                        Else
                            ActiveCell.Value = ActiveCell.Value & Chr(10) & Fname(fnum)
                        End If
                    End If
                Next fnum

                With Me.Range("J1").EntireColumn
                    .ColumnWidth = 255
                    .AutoFit
                End With
                With Me.Rows
                    .AutoFit
                End With
            End If
        Else
            MsgBox "Select a cell in the ""Attach other files"" column", 48, "RDBMailPDFOutlook"
        End If
    End Sub



    Private Sub Worksheet_Change(ByVal Target As Range)
        If Target.Column > 3 And Target.Column < 7 And Target.Row > 6 Then
            With Range(Target.Address)
                .Hyperlinks.Delete
            End With
        End If
    End Sub

    Wednesday, November 4, 2015 4:43 PM

Answers

  • >>>everything works great but i want to use my mailmerge document to the email address i have. can someone please help me with this

    According to your description, if you want that Word pulls names, addresses, and other information directly from your Excel spreadsheet into the email messages, labels, envelopes, or documents you’re creating, when you run a mail merge. You could refer to below:

    Sub RunMerge()
    
        Dim wd As Object
        Dim wdocSource As Object
    
        Dim strWorkbookName As String
    
        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("D:\WordMerge.docx")
    
        strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
    
        wdocSource.MailMerge.MainDocumentType = wdMail
        wdocSource.MailMerge.OpenDataSource _
        Name:=strWorkbookName, _
        AddToRecentFiles:=False, _
        Revert:=False, _
        Format:=wdOpenFormatAuto, _
        Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
        SQLStatement:="SELECT * FROM `Sheet1$`"
                      
        With wdocSource.MailMerge
            .Destination = wdSendToEmail
            'Sheet1 field contains the email address
            .MailAddressFieldName = "EmailAddress"
            .MailSubject = "Automated Test"
            
            .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
    

    For more information, click here to refer about MailMerge Object (Word)

    >>>Basically i have word document created a mail merge to pull out the information from excel workbook but i also want to include pdf with the mail merge document to email.

    You cannot add an attachment when performing a merge to an e-mail message. Microsoft Office Word doesn’t support this functionality. But as a workaround, you could mailmerge the documents first and send the documents via Outlook automation.


    Saturday, November 7, 2015 5:36 AM