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

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

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.