Copilot for Microsoft 365 Tech Accelerator
Feb 28 2024 07:00 AM - Feb 29 2024 10:30 AM (PST)
Microsoft Tech Community

VBA creates PDF attachment & saves but does not generate the email and attach

Copper Contributor

Hello,

 

   I have used the following VBA to create a PDF attachment and email to a group of recipients. It is creating the PDF in the same folder as where the Excel file is but it does not create the email or attach. The debug highlights the .Attachments.Add PdfFile as the issue. I am not all that familiar with VBAs and it has worked in the paste. Any ideas on what the issue is or how to fix? 

 

    This is my VBA.

 

Sub EmailPDF()
Dim AttachActiveSheetPDF()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object

' Not sure for what the Title is
Title = Range("P20")

' Define PDF filename
PdfFile = Title
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"

' Export activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With

' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0

' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)

' Prepare e-mail
.Subject = Title
.To = Range("P21").Value
.Body = "Please see attached evaluation." & vbLf & vbLf _
& "The report is attached in PDF format." & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile

' Try to send
On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0

End With

' Delete PDF file
Kill PdfFile

' Quit Outlook if it was created by this code
If IsCreated Then OutlApp.Quit

' Release the memory of object variable
Set OutlApp = Nothing

End Sub

 

11 Replies

@JoeyS-1701 

Cell P20 should contain the path and filename. The code will add the sheet name to it, plus the extension .pdf.

If P20 does not contain the path, you should add it in the code:

 

PdfFile = ThisWorkbook.Path & "\" & Title

 

I'd - at least temporarily - change .Send to .Display

Outlook should then display the email message for you to inspect. You can click Send manually.

@Hans Vogelaar 

 

Thank you. That does generate an email that is displayed, with the PDF attached, for review and can be sent. Much appreciated.

I am having this same issue with different spreadsheets. These were all built by someone who self taught VBA. They work sometimes but when they don't work it is always the same error.

Below is an example: 

@Hans Vogelaar

 

The bold italic is where I always get the error. 

Appreciate any help. 

@Hans Vogelaar 

@JoeyS-1701 

With permission everyone, if I may add this code.

Maybe this code will help you in your project :)

This code is from a website that, as far as I can see, deals with it.

Can only recommend this site for sending emails.

************************************************** ********************
'Module: Type: General module
' ************************************************* *********************

OptionExplicit

'Don't Change!
Private Const cstrSchema As String = "http://schemas.microsoft.com/cdo/configuration/"
'End Don't Change!

Private Const cstrSMTPServer As String = "mail.provider.com" 'Fill in your SMTP server!
Private Const cstrUSERNAME As String = "Your Username" 'Fill in your Mailaccount Username
Private Const cstrPASSWORD As String = "Your Password" 'Fill in your Mailaccount Password
Private Const cstrADDRESS As String = "email address removed for privacy reasons" 'Your Mail-Address

Sub sendMail_CDO()
   'original code from http://www.rondebruin.nl/cdo.htm
   Dim rng As Range, rngF As Range
   Dim objMsg As Object, objConf As Object
   Dim vntFields As Variant, strBody As String
   Dim vntAttach As Variant, lngIndex As Long
  
   'Body - always use vbCrLf or vbNewLine to separate lines, don't use vbLf!
   Const strMsg As String = vbCrLf & vbCrLf & "The file is attached for your perusal." & vbCrLf & vbCrLf & _
     "Kind regards." & vbCrLf & "I"
  
   'Attachment(s)
   'One File
   Const cstrAttachment As String = "C:\Testfile.txt"
  
   ''More Files
   'Const cstrAttachment As String = "C:\Testfile.txt;C:\AnotherFile.pdf"
  
   ''None
   'Const cstrAttachment As String = ""
  
   On Error GoTo ErrExit
  
   Set objMsg = CreateObject("CDO.Message")
   Set objConf = CreateObject("CDO.Configuration")
  
   objConf.Load -1 ' CDO Source Defaults
   Set vntFields = objConf.Fields
   With vntFields
     .Item(cstrSchema & "sendusing") = 2
     .Item(cstrSchema & "smtpserver") = cstrSMTPServer
     .Item(cstrSchema & "smtpserverport") = 25
    
     'When you also get the Authentication Required Error you can add these three lines.
     ' .Item(cstrSchema & "smtpauthenticate") = 1
     ' .Item(cstrSchema & "sendusername") = cstrUSERNAME
     ' .Item(cstrSchema & "sendpassword") = cstrPASSWORD
    
     .Update
   End With
  
   With Application
     .EnableEvents = False
     .ScreenUpdating = False
   End With
  
   With Sheets("Sheet1")
     Set rngF = .Range(.Cells(2, 8), .Cells(.Cells(.Rows.Count, 8).End(xlUp).Row, 8))
   End With
  
   'Mail addresses are in column H, names with salutation in column G
   For Each rng In rngF
     If rng Like "*@*.*" Then
       With objMsg
         strBody = "Dear" & IIf(Left(rng.Offset(0, -1).Text, 1) = "F", " " & _
           rng.Offset(0, -1).Text, "r " & rng.Offset(0, -1).Text) & "!" & strMsg
        
         Set .Configuration = objConf
         .To = rng.Text
         .CC = ""
         .BCC = ""
         .From = cstrADDRESS 'Sender
         .Subject = "Testmail" 'Subject
         .TextBody = strBody
        
         If Len(cstrAttachment) Then
           vntAttach = Split(cstrAttachment, ";")
           For lngIndex = 0 To UBound(vntAttach)
             If Dir(vntAttach(lngIndex), vbNormal) <> "" Then .AddAttachment vntAttach(lngIndex)
           Next
         End If
        
         ' ' Set importance or priority to high
         ' .Fields("urn:schemas:httpmail:importance") = 2
         ' .Fields("urn:schemas:mailheader:X-Priority") = 1
         '
         ' ' Request read receipt
         ' .Fields("urn:schemas:mailheader:return-receipt-to") = cstrADDRESS
         ' .Fields("urn:schemas:mailheader:disposition-notification-to") = cstrADDRESS
         '
         ' ' Updatefields
         ' .Fields.Update
        
         .send
       End With
     End If
   Next
  
   ErrExit:
  
   If Err.Number <> 0 Then
     MsgBox "Error:" & vbTab & Err.Number & vbLf & vbLf & Err.Description & _
       vbLf & vbLf, vbExclamation, "Error"
   End If
  
   With Application
     .EnableEvents = True
     .ScreenUpdating = True
   End With
  
   Set rng = Nothing
   Set rngF = Nothing
   Set objConf = Nothing
   Set objMsg = Nothing
end sub

 

 

 

 

 

 

Thank you for your understanding and patience

 

NikolinoDE

I know I don't know anything (Socra

Hello,

I have an excel with multiple sheets and l want to send the details from every sheet (starting with sheet no 4) in format pdf to e-mail, but l can't manage to make it automatically for all sheets, just the active one (yes, l know l have post it with "AttachActiveSheetPDF" but l don't know how to put for all)
Can you help me?


Sub EmailPDF()

Dim AttachActiveSheetPDF()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object

' Not sure for what the Title is
Title = Range("M3")

' Define PDF filename
PdfFile = Title
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i + 1)
PdfFile = PdfFile & ".pdf"

' Export activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With

' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0

' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)

' Prepare e-mail
.Subject = Title
.To = Range("A1").Value
.Body = "Hello! Please see attached the annex for utility invoice." & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile

' Try to send
On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0

End With

' Delete PDF file
Kill PdfFile

' Quit Outlook if it was created by this code
If IsCreated Then OutlApp.Quit

' Release the memory of object variable
Set OutlApp = Nothing

End Sub



@ralucatarsana 

As far as I can understand, the code is only exporting the active sheet as PDF, not all the sheets.

To export all the sheets starting from sheet 4, you need to loop through them and use the Worksheet.ExportAsFixedFormat method instead of ActiveSheet.ExportAsFixedFormat.

You also need to change the PDF filename for each sheet to avoid overwriting the same file.

 

Here is a modified version of your code that should work (not tested :):

Sub EmailPDF()

Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim ws As Worksheet

' Not sure for what the Title is
Title = Range("M3")

' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0

' Prepare e-mail with PDF attachments
With OutlApp.CreateItem(0)

' Prepare e-mail
.Subject = Title
.To = Range("A1").Value
.Body = "Hello! Please see attached the annex for utility invoice." & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf

' Loop through sheets starting from sheet 4 and export them as PDF
For Each ws In Worksheets

If ws.Index >= 4 Then

' Define PDF filename based on sheet name
PdfFile = ws.Name & ".pdf"

' Export worksheet as PDF
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

' Attach PDF file to e-mail
.Attachments.Add PdfFile

End If

Next ws

' Try to send
On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0

End With

' Delete PDF files after sending e-mail
For Each ws In Worksheets

If ws.Index >= 4 Then

PdfFile = ws.Name & ".pdf"
Kill PdfFile

End If

Next ws

' Quit Outlook if it was created by this code
If IsCreated Then OutlApp.Quit

' Release the memory of object variable
Set OutlApp = Nothing

End Sub

 

Hope I was able to help you :).

 

NikolinoDE

I know I don't know anything (Socrates)

@NikolineDE
thank you, but is not working. i receive the message "e-mail was not sent".
regarding the pdf name, i already have a macro that changes automatically the name "Annex 1, Annex 2, etc)

@ralucatarsana 

This error can occur for various reasons, either your macro settings are wrong, or the code is stuck on some line.

Anyway, I can't manage to let it all run through in time, or help.

Attached is a file, maybe one of the examples fits well into your project.

This link has informations about the attached file.

 

I wish you much success and fun with Excel.

@Hans Vogelaar 

If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & ".pdf"

With Sheets("Cash Over Short")
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With

On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0

With OutlApp.CreateItem(0)

.Subject = Title
.To = Sheets("Reference").Range("A30").Value
.CC = ""
.Body = "Hi," & vbLf & vbLf _
& "Please find L&L daily cash over/short in PDF attachment." & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile

On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0

End With
Kill PdfFile
If IsCreated Then OutlApp.Quit
Set OutlApp = Nothing
ElseIf Sheets("Closing Count").Range("B1") = "Michael Jordan" Then
Dim IsCreatedMJ As Boolean
Dim iMJ As Long
Dim PdfFileMJ As String, TitleMJ As String
Dim OutlAppMJ As Object
TitleMJ = Format(Sheets("Cash Over Short").Range("B14"), "mm/dd/yy") & " " & "Michael Jordan Cash Over Short"
PdfFileMJ = "MJ Cash Over Short" & " " & Format(Sheets("Cash Over Short").Range("B14"), "yymmdd")
iMJ = InStrRev(PdfFileMJ, ".")
If iMJ > 1 Then PdfFileMJ = Left(PdfFileMJ, iMJ - 1)
PdfFileMJ = PdfFileMJ & ".pdf"

With Sheets("Cash Over Short")
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFileMJ, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With

On Error Resume Next
Set OutlAppMJ = GetObject(, "Outlook.Application")
If Err Then
Set OutlAppMJ = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlAppMJ.Visible = True
On Error GoTo 0

With OutlAppMJ.CreateItem(0)

.Subject = TitleMJ
.To = Sheets("Reference").Range("B30").Value
.CC = ""
.Body = "Hi," & vbLf & vbLf _
& "Please find MJ daily cash over/short in PDF attachment." & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFileMJ

On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0

End With
Kill PdfFileMJ
If IsCreated Then OutlAppMJ.Quit
Set OutlAppMJ = Nothing
Else
End If
End Sub

@Sbrowning 

It's difficult to understand the logic of your code, especially since you didn't post all of it, and since the posted version doesn't have any indentation. Perhaps this?

    If i > 1 Then PdfFile = Left(PdfFile, i - 1)
    PdfFile = PdfFile & ".pdf"

    With Sheets("Cash Over Short")
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End With

    On Error Resume Next
    Set OutlApp = GetObject(, "Outlook.Application")
    If Err Then
        Set OutlApp = CreateObject("Outlook.Application")
        IsCreated = True
    End If
    OutlApp.Visible = True
    On Error GoTo 0

    With OutlApp.CreateItem(0)

        .Subject = Title
        .To = Sheets("Reference").Range("A30").Value
        .CC = ""
        .Body = "Hi," & vbLf & vbLf _
        & "Please find L&L daily cash over/short in PDF attachment." & vbLf & vbLf _
        & "Regards," & vbLf _
        & Application.UserName & vbLf & vbLf
        .Attachments.Add PdfFile

        On Error Resume Next
        .Send
        Application.Visible = True
        If Err Then
            MsgBox "E-mail was not sent", vbExclamation
        Else
            MsgBox "E-mail successfully sent", vbInformation
        End If
        On Error GoTo 0

    End With
    Kill PdfFile
    If IsCreated Then
        OutlApp.Quit
        Set OutlApp = Nothing
    ElseIf Sheets("Closing Count").Range("B1") = "Michael Jordan" Then
        Dim IsCreatedMJ As Boolean
        Dim iMJ As Long
        Dim PdfFileMJ As String, TitleMJ As String
        Dim OutlAppMJ As Object
        TitleMJ = Format(Sheets("Cash Over Short").Range("B14"), "mm/dd/yy") & " " & "Michael Jordan Cash Over Short"
        PdfFileMJ = "MJ Cash Over Short" & " " & Format(Sheets("Cash Over Short").Range("B14"), "yymmdd")
        iMJ = InStrRev(PdfFileMJ, ".")
        If iMJ > 1 Then PdfFileMJ = Left(PdfFileMJ, iMJ - 1)
        PdfFileMJ = PdfFileMJ & ".pdf"

        With Sheets("Cash Over Short")
            .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFileMJ, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        End With

        On Error Resume Next
        Set OutlAppMJ = GetObject(, "Outlook.Application")
        If Err Then
            Set OutlAppMJ = CreateObject("Outlook.Application")
            IsCreated = True
        End If
        OutlAppMJ.Visible = True
        On Error GoTo 0

        With OutlAppMJ.CreateItem(0)

            .Subject = TitleMJ
            .To = Sheets("Reference").Range("B30").Value
            .CC = ""
            .Body = "Hi," & vbLf & vbLf _
            & "Please find MJ daily cash over/short in PDF attachment." & vbLf & vbLf _
            & "Regards," & vbLf _
            & Application.UserName & vbLf & vbLf
            .Attachments.Add PdfFileMJ

            On Error Resume Next
            .Send
            Application.Visible = True
            If Err Then
                MsgBox "E-mail was not sent", vbExclamation
            Else
                MsgBox "E-mail successfully sent", vbInformation
            End If
            On Error GoTo 0

        End With
        Kill PdfFileMJ
        If IsCreated Then OutlAppMJ.Quit
        Set OutlAppMJ = Nothing
    End If
End Sub