VBA to email out of excel with a PDF attachment

[Sammi8796]

Hello-

I have this code that I was able to string together that would email from Excel using Outlook. Honestly, it is barely doing what I would like it to do. What i'm trying to do, I'm sure is very simple for you guys. I have a distribution list with many rows. Basic name with email address. I want to have a VBA code that will email each row the same text in an email. I want it to attach the same PDF to every email. I would also like to be able to enter a signature card in that email, but I don't know how to do that. Here is what I have so far. Can someone please tell me what I should enter in VBA to accomplish this? I'm super pressed for time because my manager is wanting this ASAP and I have already spend about 2 days trying to pull this together. Any help I can get I would appreciate greatly. Thank you!

Sub SendEmail(what_address As String, subject_line As String, mail_body As String)

Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")

Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)

olMail.To = what_address
olMail.Subject = subject_line
olMail.Body = mail_body
olMail.Send


End Sub
Sub SendMassEmail()

row_number = 1

Do
DoEvents
row_number = row_number + 1
Dim mail_body_message As String
Dim full_name As String
mail_body_message = Sheet2.Range("J2")
full_name = Sheet2.Range("c" & row_number)
mail_body_message = Replace(mail_body_message, "replace_name_here", full_name)
Call SendEmail(Sheet2.Range("A" & row_number), "Request for Tax Exemption Certificate", mail_body_message)
Loop Until row_number = 4


End Sub

 

[Sammi8796]

Guys please help me out- I know this is probably very easy for you geniuses.

 

[John_w]

Try this Excel macro. It uses early binding of the Outlook objects (same as your code), so you must set a reference to MS Outlook n.00 Object Library, via Tools -> References in the VBA editor.

You need to edit the code where shown, to specify the folder path and name of the PDF file attachment.

The code creates each email with Outlook's automatic default signature for new emails, and adds the email body text to the internal HTML. The code which manipulates the HTML is written for Outlook 2016 and will need to be changed for earlier versions because the structure of the internal HTML is slightly different. Also note that I've had to add a space after every "<" tag character (otherwise the forum software tries to render the tag) and call the RS function to remove this space, so this part of the code looks more complicated than it is.

As posted, the emails are saved in the Drafts folder, allowing you to check them and send them manually. To send them automatically, uncomment the .Send line and delete the .Save line.

Public Sub Send_Emails()

    Dim lastRow As Long, r As Long
    Dim mail_body_message As String
    Dim full_name As String
    Dim PDFfile As String
    
    PDFfile = "C:\folder\path\The PDF file.pdf"   'CHANGE THIS
            
    With Worksheets("Sheet2")
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For r = 2 To lastRow
            mail_body_message = Replace(.Range("J2").Value, "replace_name_here", .Cells(r, "C").Value)
            Send_Email_with_Signature .Cells(r, "A").Value, "Request for Tax Exemption Certificate", mail_body_message, PDFfile
            DoEvents
        Next
    End With

End Sub


Private Sub Send_Email_with_Signature(toEmailAddress As String, subjectLine As String, emailBody As String, attachmentFullName As String)

    Dim OutApp As Outlook.Application
    Dim OutMail As Object                     'must be Object, even with early binding
    Dim p1 As Long, p2 As Long
    Dim HTML As String, newHTML As String
    
    'Paragraphs to be inserted in email body text. Put each paragraph in a [p]...[/p] tag, and [br] tag for a new line within a paragraph
    
    newHTML = RS("< p>") & emailBody & RS("< /p>")
    
    Set OutApp = New Outlook.Application
    Set OutMail = OutApp.CreateItem(olMailItem)
    
    With OutMail
        .GetInspector
        HTML = .HTMLbody
    End With
        
    'Remove first 2 [p] tags in HTMLbody.  In Outlook 2016 both these contain only  , resulting in blank paragraphs
    '[p class=MsoNormal][o:p] [/o:p][/p][p class=MsoNormal][o:p] [/o:p][/p][p class=MsoNormal]
    
    p1 = InStr(1, HTML, RS("< p "), vbTextCompare)
    p2 = InStr(p1 + 1, HTML, RS("< p "), vbTextCompare)
    p2 = InStr(p2, HTML, RS("< /p>"), vbTextCompare)
    HTML = Left(HTML, p1 - 1) & Mid(HTML, p2 + Len(RS("< /p>")))
    
    'Find end of opening body tag and insert new HTML after it
    
    p1 = InStr(1, HTML, RS("< body"), vbTextCompare)
    p1 = InStr(p1, HTML, ">")
    HTML = Left(HTML, p1) & newHTML & Mid(HTML, p1 + 1)
    
    With OutMail
        .To = toEmailAddress
        .Subject = subjectLine
        .HTMLbody = HTML
        If attachmentFullName <> "" Then .Attachments.Add attachmentFullName
        '.Send          'uncomment this line and delete the .Save line to send the email
        .Save
    End With
    
End Sub


Private Function RS(HTML As String) As String
    RS = Replace(HTML, "< ", "<")
End Function