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
Mar 23 2023 11:17 AM
Mar 23 2023 11:27 PM
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 :).
I know I don't know anything (Socrates)
Mar 23 2023 11:58 PM
Mar 24 2023 12:50 AM
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.
Apr 11 2023 09:59 AM
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
Apr 11 2023 12:15 PM
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