Sending PDF through outlook using excel macros

S

Swap

New Member
Joined
Dec 24, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
Hi Everyone,

I'm using the below code to send PDFs using outlook.
My outlooks has multiple emails configured, and I need the code to use a specific email address instead of the default one

Any suggestions would be greatly appreciated
Thanks in advance



VBA Code: 
Sub SendEmailWithPDF(bTest As Boolean)
Dim wsM As Worksheet
Dim wsL As Worksheet
Dim wsR As Worksheet
Dim wsS As Worksheet
Dim rngL As Range
Dim rngSN As Range
Dim rngTN As Range
Dim rngPath As Range
Dim c As Range
Dim lSend As Long
Dim lSent As Long
Dim lCount As Long
Dim lTest As Long
Dim lOff As Long

Dim OutApp As Object
Dim OutMail As Object
Dim strSavePath As String
Dim strPathTest As String
Dim strPDFName As String
Dim strSendTo As String
Dim strSubj As String
Dim strBody As String
Dim strMsg As String
Dim strConf As String

On Error GoTo errHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False

strMsg = "Could not set variables"
Set wsM = wksMenu
Set wsS = wksSet
Set wsL = wksList
Set wsR = wksRpt
Set rngL = wsL.Range("StoreNums")
Set rngSN = wsR.Range("rngSN")
Set rngTN = wsS.Range("rngTN")
Set rngPath = wsS.Range("rngPath")
'test email address
strSendTo = wsS.Range("rngSendTo").Value

lCount = rngL.Cells.Count
'#columns offset for email address
lOff = 3

If bTest = True Then
   strConf = "TEST Emails: "
   lTest = rngTN.Value
   If lTest > 0 Then
      lCount = lTest
   End If
Else
   strConf = "STORE Emails: "
End If

strConf = strConf & lCount _
      & " emails will be sent"

If bTest = True Then
  If strSendTo = "" Then
    MsgBox "Enter a test email address" _
     & vbCrLf _
     & "and try again."
    GoSettings
    GoTo exitHandler
  Else
    strConf = strConf & vbCrLf _
      & "to " & strSendTo
  End If
End If

strConf = strConf & vbCrLf & vbCrLf
strConf = strConf & "Please confirm: " _
  & vbCrLf & _
  "Do you want to send the emails?"

lSend = MsgBox(strConf, _
  vbQuestion + vbYesNo, "Send Emails")

If lSend = vbYes Then
  strSubj = wsS.Range("rngSubj").Value
  strBody = wsS.Range("rngBody").Value
  strSavePath = rngPath.Value
 
  strMsg = "Could not test Outlook"
  On Error Resume Next
  Set OutApp = _
   GetObject(, "Outlook.Application")
  On Error GoTo errHandler

  If OutApp Is Nothing Then
      MsgBox "Outlook is not open. " _
       & vbCrLf _
       & "Open Outlook and try again"
      GoTo exitHandler
  End If
 
  strMsg = "Could not set path" _
     & " for PDF save folder"
  If Right(strSavePath, 1) <> "\" Then
      strSavePath = strSavePath & "\"
  End If
 
  If DoesPathExist(strSavePath) Then
    'continue code below,
    ' using strSavePath
  Else
    MsgBox "The Save folder, " _
      & strSavePath _
      & vbCrLf & "does not exist." _
      & vbCrLf & _
        "Files could not be created." _
      & vbCrLf & _
        "Please select valid folder."
      wsS.Activate
      rngPath.Activate
    GoTo exitHandler
  End If

  strMsg = "Could not start mail process"
  For Each c In rngL
     rngSN = c.Value
    
     strMsg = "Could not create PDF for " _
         & c.Value
     strPDFName = "SalesReport_" _
         & c.Value & ".pdf"
     If bTest = False Then
        strSendTo = c.Offset(0, lOff).Value
     End If
      wsR.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=strSavePath _
          & strPDFName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
     
      Set OutMail = OutApp.CreateItem(0)
 
     strMsg = "Could not start mail for " _
           & c.Value
      On Error Resume Next
      With OutMail
          .To = strSendTo
          .CC = ""
          .BCC = ""
          .Subject = strSubj
          .Body = strBody
          .Attachments.Add _
             strSavePath & strPDFName
          .Send
      End With
      On Error GoTo 0
     lSent = lSent + 1
     If lSent >= lCount Then Exit For
  Next c
 
  Application.ScreenUpdating = True
  wsM.Activate
 
  MsgBox "Emails have been sent"
 
End If

exitHandler:
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   Set OutMail = Nothing
   Set OutApp = Nothing
  
   Set wsM = Nothing
   Set wsS = Nothing
   Set wsL = Nothing
   Set wsR = Nothing
   Set rngL = Nothing
   Set rngSN = Nothing
   Set rngPath = Nothing
  
   Exit Sub
  
errHandler:
   MsgBox strMsg
   Resume exitHandler

End Sub
 
Last edited by a moderator:

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Sort by date Sort by votes
Welcome to the MrExcel Message Board!

Assuming everything else in the code is working fine for you, to set the sender account, try using .SendUsingAccount method. I added it as the second line in your code.

Change "sample@example.com" with an existing account in Outlook.

VBA Code: 
      With OutMail
          .SendUsingAccount = OutApp.Session.Accounts.Item("sample@example.com")
          .To = strSendTo
          .CC = ""
          .BCC = ""
          .Subject = strSubj
          .Body = strBody
          .Attachments.Add _
             strSavePath & strPDFName
          .Send
      End With
 
Upvote 0
HI Smozgur,

Thanks a lot for your help and happy festive season

Post incorporating your suggestion, I put the sender as my personal email address.
I got the msg: "Mails have been sent". But never really got the email

So, I think something is conflicting here.. May i kindly seek your help here
Code below
____________________________________________

VBA Code: 
Option Explicit

Sub SendEmailTest()
SendEmailWithPDF (True)
End Sub

Sub SendEmailStores()
SendEmailWithPDF (False)
End Sub


Sub SendEmailWithPDF(bTest As Boolean)
Dim wsM As Worksheet
Dim wsL As Worksheet
Dim wsR As Worksheet
Dim wsS As Worksheet
Dim rngL As Range
Dim rngSN As Range
Dim rngTN As Range
Dim rngPath As Range
Dim c As Range
Dim lSend As Long
Dim lSent As Long
Dim lCount As Long
Dim lTest As Long
Dim lOff As Long

Dim OutApp As Object
Dim OutMail As Object
Dim strSavePath As String
Dim strPathTest As String
Dim strPDFName As String
Dim strSendTo As String
Dim strSubj As String
Dim strBody As String
Dim strMsg As String
Dim strConf As String

On Error GoTo errHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False

strMsg = "Could not set variables"
Set wsM = wksMenu
Set wsS = wksSet
Set wsL = wksList
Set wsR = wksRpt
Set rngL = wsL.Range("StoreNums")
Set rngSN = wsR.Range("rngSN")
Set rngTN = wsS.Range("rngTN")
Set rngPath = wsS.Range("rngPath")
'test email address
strSendTo = wsS.Range("rngSendTo").Value

lCount = rngL.Cells.Count
'#columns offset for email address
lOff = 3

If bTest = True Then
strConf = "TEST Emails: "
lTest = rngTN.Value
If lTest > 0 Then
      lCount = lTest
   End If
Else
   strConf = "STORE Emails: "
End If

strConf = strConf & lCount _
      & " emails will be sent"

If bTest = True Then
  If strSendTo = "" Then
    MsgBox "Enter a test email address" _
     & vbCrLf _
     & "and try again."
    GoSettings
    GoTo exitHandler
  Else
    strConf = strConf & vbCrLf _
      & "to " & strSendTo
  End If
End If

strConf = strConf & vbCrLf & vbCrLf
strConf = strConf & "Please confirm: " _
  & vbCrLf & _
  "Do you want to send the emails?"

lSend = MsgBox(strConf, _
  vbQuestion + vbYesNo, "Send Emails")

If lSend = vbYes Then
  strSubj = wsS.Range("rngSubj").Value
  strBody = wsS.Range("rngBody").Value
  strSavePath = rngPath.Value
 
  strMsg = "Could not test Outlook"
  On Error Resume Next
  Set OutApp = _
   GetObject(, "Outlook.Application")
  On Error GoTo errHandler

  If OutApp Is Nothing Then
      MsgBox "Outlook is not open. " _
       & vbCrLf _
       & "Open Outlook and try again"
      GoTo exitHandler
  End If
 
  strMsg = "Could not set path" _
     & " for PDF save folder"
  If Right(strSavePath, 1) <> "\" Then
      strSavePath = strSavePath & "\"
  End If
 
  If DoesPathExist(strSavePath) Then
    'continue code below,
    ' using strSavePath
  Else
    MsgBox "The Save folder, " _
      & strSavePath _
      & vbCrLf & "does not exist." _
      & vbCrLf & _
        "Files could not be created." _
      & vbCrLf & _
        "Please select valid folder."
      wsS.Activate
      rngPath.Activate
    GoTo exitHandler
  End If

  strMsg = "Could not start mail process"
  For Each c In rngL
     rngSN = c.Value
    
     strMsg = "Could not create PDF for " _
         & c.Value
     strPDFName = "Invoice Details_Hotel-ID " _
         & c.Value & ".pdf"
     If bTest = False Then
        strSendTo = c.Offset(0, lOff).Value
     End If
      wsR.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=strSavePath _
          & strPDFName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    
      Set OutMail = OutApp.CreateItem(0)
              
     
 
     strMsg = "Could not start mail for " _
           & c.Value
      On Error Resume Next
      With OutMail
          .SendUsingAccount = OutApp.Session.Accounts.Item("sample@example.com")
          .To = strSendTo
          .CC = ""
          .BCC = ""
          .Subject = strSubj
          .Body = strBody
          .Attachments.Add _
             strSavePath & strPDFName
          .Send
      End With
      On Error GoTo 0
     lSent = lSent + 1
     If lSent >= lCount Then Exit For
  Next c
 
  Application.ScreenUpdating = True
  wsM.Activate
 
  MsgBox "Emails have been sent"
 
End If

exitHandler:
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   Set OutMail = Nothing
   Set OutApp = Nothing
  
   Set wsM = Nothing
   Set wsS = Nothing
   Set wsL = Nothing
   Set wsR = Nothing
   Set rngL = Nothing
   Set rngSN = Nothing
   Set rngPath = Nothing
  
   Exit Sub
  
errHandler:
   MsgBox strMsg
   Resume exitHandler

End Sub

Function DoesPathExist _
  (myPath As String) As Boolean
  Dim TestStr As String
  If Right(myPath, 1) <> "\" Then
      myPath = myPath & "\"
  End If
  TestStr = ""
  On Error Resume Next
  TestStr = Dir(myPath & "nul")
  On Error GoTo 0

  DoesPathExist = CBool(TestStr <> "")

End Function

Sub GetFolderFilesPDF()
Dim rngPath As Range
Dim PathStart As String
On Error Resume Next

Set rngPath = wksSet.Range("rngPath")
PathStart = ActiveWorkbook.Path
 
With Application.FileDialog _
(msoFileDialogFolderPicker)
   .AllowMultiSelect = False
   .InitialFileName = PathStart
   .Show
   
   If .SelectedItems.Count > 0 Then
       rngPath.Value = _
         .SelectedItems(1)
   End If
   
End With
 
End Sub
 
Last edited by a moderator:
Upvote 0
@Swap: I edited your code once again to wrap the VBA code by using the code tags. Please try to do that next time since it is easier to read code snippets that way.
Another point is that I also removed your email address from the code since it is personal information. Please do not share real email addresses in your sample codes.

Swap said:
So, I think something is conflicting here.. May i kindly seek your help here
Click to expand...
Instead of using .Send method in your code, use .Display method to see the mail item to make sure how the sender is set. The sender email account should be correct by using the property I explained.

I can't test your code until tomorrow, however, if the email is not being sent, then it should be something else in the code.
Disable all error handlers (On Error ... lines) and re-run your code. Then you should see the actual error.
 
Upvote 0
Hi smozgur,

I did check the codes again.. using display.
But it is still using the same email address

I also tried changing outlook settings to make the mailbox i need to send from the default address, still its considering the other one

Would be great if you are able to help me on this
 
Upvote 0
You must log in or register to reply here.

Similar threads

earthworm
  • Question Question
Autofit table in Outlook upon copying from Excel sheet using Macro
Replies
1
Views
223
KOKOSEK
KOKOSEK
J
  • Question Question
Outlook Email not opening from Excel Macro. Was previously working fine for months
Replies
1
Views
766
Domenic
D
C
  • Solved
How to send these created outlook emails?
Replies
3
Views
831
cutemeatball
C
N
  • Question Question
send each sheet to each persons via outlook
2
Replies
11
Views
2K
dmt32
D
excelbytes
  • Solved
Send E-Mail From Outlook If Date Is Overdue In Excel
2
Replies
14
Views
3K
Anakin89
A

Forum statistics

Threads
1,224,880
Messages
6,181,532
Members
453,054
Latest member
ezzat

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