Send using a Different Outlook Email Account, attached PDF + Body + Signature.

G

GijoeBlack

New Member
Joined
Sep 22, 2021
Messages
23
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. MacOS
Hello Again

@Zot has been kind and helpful on another VBA excel issue. Hoping him or someone else can resolve this mystery. I'm using Altered version of here. My ONLY challenge is that my Outlook has more than one account and it seems to be default to a account that I DONOT want to use to Send email FROM the attached PDF with pre-defined Body wSignature per link above. I have attempted to set the email account that I intend to use as "default" in Outlook but did not solve the issue. Some trial and error, am off the opinion its something to do with using HTML signature. I have also reviewed "rondebruin's" code to find and utilize 1st or 2nd etc item, but can't get it to work aka while SendUsingAccount works fine, it attaches PDF correct, populates "Body" fine but does not include the HTML Signature. Not sure if this has to do with how the variables are Dimmed.

NOTE: since the base code is from the link posted above aka "Create PDF from current sheet and email as attachment", I would prefer altered version to include ability to define either SendUsingAccount or SentonBehalfofName options.

I would like to thank in advance for your efforts. Look forward to response.

Joe.
 
Sort by date Sort by votes
Hi GijoeBlack,

the following code works on my system, you should give it a go on yours. Feel free to alter the line
Code: 
        Set .SendUsingAccount = OutlookApp.Session.Accounts.Item(2)
as I wanted to get hold of the second account in my Outlook.

VBA Code: 
Sub create_and_email_pdf_211005()
' Author - Philip Treacy  ::   http://www.linkedin.com/in/philiptreacy
' http://www.MyOnlineTrainingHub.com/vba-to-create-pdf-from-excel-worksheet-then-email-it-with-outlook
' Date - 14 Oct 2013
' Create a PDF from the current sheet and email it as an attachment through Outlook

Dim EmailSubject As String, EmailSignature As String, CurrentInv As String, Title As String, Signature As String
Dim CurrentMonth As String, DestFolder As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object, outAccount As Object
Dim strbody As String

CurrentInv = ""
Title = Range("J4")
strbody = "<H2><B>Dear Valued Client</B></H2>" & _
              "I hope this finds you well. Enclosed please find your Invoice.<br>" & _
              "Please contact if you have any questions regarding this invoice.<br>" & _
              "You can also reach our billing & accounting team at: accounting@email.com.<br>" & _
              "<br><br><B>We thank you for your business.</B>"

' *****************************************************
' *****     You Can Change These Variables    *********

    EmailSubject = "Your Invoice# " & Range("J4").Value & " " & "Dated " & Range("J5").Value 'Change this to change the subject of the email. The current month is added to end of subj line
    OpenPDFAfterCreating = False    'Change this if you want to open the PDF after creating it : TRUE or FALSE
    AlwaysOverwritePDF = False      'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE
    DisplayEmail = True 'Change this if you don't want to display the email before sending.  Note, you must have a TO email address specified for this to work
    Email_To = ActiveSheet.Range("C16")   'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
    Email_CC = ""
    Email_BCC = ""
           
' ******************************************************
    
    'Prompt for file destination
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            DestFolder = .SelectedItems(1)
        Else
            MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
            Exit Sub
        End If
    End With

    'Current month/year stored in H6 (this is a merged cell)
    'CurrentMonth = Mid(ActiveSheet.Range("H6").Value, InStr(1, ActiveSheet.Range("H6").Value, " ") + 1)
    
    'Current Invoice Number stored in J4
    CurrentInv = ActiveSheet.Range("J4").Value
    
    'Create new PDF file name including path and file extension
    PDFFile = DestFolder & Application.PathSeparator & "Your - " & "INV" & "_" & CurrentInv & "_" & ActiveSheet.Name _
                 & ".pdf"

    'If the PDF already exists
    If Len(Dir(PDFFile)) > 0 Then
        If AlwaysOverwritePDF = False Then
            OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
            On Error Resume Next
            'If you want to overwrite the file then delete the current one
            If OverwritePDF = vbYes Then
                Kill PDFFile
            Else
                MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
                Exit Sub
            End If
        Else
            On Error Resume Next
            Kill PDFFile
        End If
        If Err.Number <> 0 Then
            MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
            Exit Sub
        End If
    End If

    'Create the PDF
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    FileName:=PDFFile, _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=OpenPDFAfterCreating

    '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
        .Signature = .Body
        .Display
        .To = Email_To
        .CC = Email_CC
        .BCC = Email_BCC
        .Subject = EmailSubject & CurrentMonth
        .Attachments.Add PDFFile
        .HTMLBody = strbody & "<br>" & .HTMLBody
        Set .SendUsingAccount = OutlookApp.Session.Accounts.Item(2)
       'Set .SentOnBehalfOfName = "another@email.com"
        If DisplayEmail = False Then
            .Send
        End If
    End With
 
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
 
End Sub
Ciao,
Holger
 
Upvote 0
Solution

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
HaHoBe said:
Hi GijoeBlack,

the following code works on my system, you should give it a go on yours. Feel free to alter the line
Code: 
        Set .SendUsingAccount = OutlookApp.Session.Accounts.Item(2)
as I wanted to get hold of the second account in my Outlook.

VBA Code: 
Sub create_and_email_pdf_211005()
' Author - Philip Treacy  ::   http://www.linkedin.com/in/philiptreacy
' http://www.MyOnlineTrainingHub.com/vba-to-create-pdf-from-excel-worksheet-then-email-it-with-outlook
' Date - 14 Oct 2013
' Create a PDF from the current sheet and email it as an attachment through Outlook

Dim EmailSubject As String, EmailSignature As String, CurrentInv As String, Title As String, Signature As String
Dim CurrentMonth As String, DestFolder As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object, outAccount As Object
Dim strbody As String

CurrentInv = ""
Title = Range("J4")
strbody = "<H2><B>Dear Valued Client</B></H2>" & _
              "I hope this finds you well. Enclosed please find your Invoice.<br>" & _
              "Please contact if you have any questions regarding this invoice.<br>" & _
              "You can also reach our billing & accounting team at: accounting@email.com.<br>" & _
              "<br><br><B>We thank you for your business.</B>"

' *****************************************************
' *****     You Can Change These Variables    *********

    EmailSubject = "Your Invoice# " & Range("J4").Value & " " & "Dated " & Range("J5").Value 'Change this to change the subject of the email. The current month is added to end of subj line
    OpenPDFAfterCreating = False    'Change this if you want to open the PDF after creating it : TRUE or FALSE
    AlwaysOverwritePDF = False      'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE
    DisplayEmail = True 'Change this if you don't want to display the email before sending.  Note, you must have a TO email address specified for this to work
    Email_To = ActiveSheet.Range("C16")   'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
    Email_CC = ""
    Email_BCC = ""
          
' ******************************************************
   
    'Prompt for file destination
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            DestFolder = .SelectedItems(1)
        Else
            MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
            Exit Sub
        End If
    End With

    'Current month/year stored in H6 (this is a merged cell)
    'CurrentMonth = Mid(ActiveSheet.Range("H6").Value, InStr(1, ActiveSheet.Range("H6").Value, " ") + 1)
   
    'Current Invoice Number stored in J4
    CurrentInv = ActiveSheet.Range("J4").Value
   
    'Create new PDF file name including path and file extension
    PDFFile = DestFolder & Application.PathSeparator & "Your - " & "INV" & "_" & CurrentInv & "_" & ActiveSheet.Name _
                 & ".pdf"

    'If the PDF already exists
    If Len(Dir(PDFFile)) > 0 Then
        If AlwaysOverwritePDF = False Then
            OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
            On Error Resume Next
            'If you want to overwrite the file then delete the current one
            If OverwritePDF = vbYes Then
                Kill PDFFile
            Else
                MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
                Exit Sub
            End If
        Else
            On Error Resume Next
            Kill PDFFile
        End If
        If Err.Number <> 0 Then
            MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
            Exit Sub
        End If
    End If

    'Create the PDF
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    FileName:=PDFFile, _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=OpenPDFAfterCreating

    '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
        .Signature = .Body
        .Display
        .To = Email_To
        .CC = Email_CC
        .BCC = Email_BCC
        .Subject = EmailSubject & CurrentMonth
        .Attachments.Add PDFFile
        .HTMLBody = strbody & "<br>" & .HTMLBody
        Set .SendUsingAccount = OutlookApp.Session.Accounts.Item(2)
       'Set .SentOnBehalfOfName = "another@email.com"
        If DisplayEmail = False Then
            .Send
        End If
    End With
 
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
 
End Sub
Ciao,
Holger
Click to expand...
Once appreciate continued help. I will give it a go and update.

Cheers.
 
Upvote 0
ok so the recent mod did the trick. Did run into an error and had to comment out ".Signature = .Body" to make it work. I can't thank you enough. Just wondering, how does ".Signature" function?

Cheers
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Sending Automated Emails with Attachments via Outlook
Replies
1
Views
222
Micron
M
L
  • Question Question
Sending Email with Table in Body
Replies
3
Views
519
Domenic
D
L
  • Locked
  • Question Question
How to stop VBA from creating pdf from drop-down list if the value is empty?
Replies
1
Views
281
Fluff
Fluff
T
  • Question Question
Excel VBA - Send email in Outlook using 2nd account
Replies
6
Views
1K
6StringJazzer
6StringJazzer
L
  • Question Question
How to fix VBA code to stop saving and emailing PDF of blank cell from data validation list?
Replies
2
Views
267
lharr28
L

Forum statistics

Threads
1,223,231
Messages
6,170,884
Members
452,364
Latest member
springate

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top