Jan 20 2021 10:46 AM
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
Jan 20 2021 12:19 PM
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.
Jan 20 2021 03:00 PM
Thank you. That does generate an email that is displayed, with the PDF attached, for review and can be sent. Much appreciated.
Dec 08 2022 07:45 PM
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:
The bold italic is where I always get the error.
Appreciate any help.
Dec 09 2022 03:41 AM
I don't see an example...
Dec 09 2022 03:59 AM - edited Dec 09 2022 04:08 AM
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
I know I don't know anything (Socra