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

[JoeyS-1701]

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

[#2]

@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.

[#3]

@Hans Vogelaar 

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

[#4]

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 

[#5]

@Sbrowning 

I don't see an example...

[#6]

@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