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