When I send email from excel with VBA it sends two times

missrutele

New Member
Joined
Nov 17, 2017
Messages
10
Dear All,

please help. It worked before but suddenly it started to send the same email few times to the same recipient if there is indicated another email in c.c.

So it works like this - I have range in excel that it makes as pdf and send an email and when it goes to next one etc.

Please help :((((((

My vba code:

Sub PDFXX()
Dim SaveAsStr As String


'SaveAsStr = ActiveWorkbook.Path & "" & ActiveSheet.Range("J1").Value
SaveAsStr = ActiveSheet.Range("J1").Value


ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=SaveAsStr & ".pdf", _
OpenAfterPublish:=False
End Sub


Sub AttachActiveSheetPDFXX()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object

'SaveAsStr = ActiveWorkbook.Path & "" & ActiveSheet.Range("J1").Value
SaveAsStr = ActiveSheet.Range("J1").Value


ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=SaveAsStr & ".pdf", _
OpenAfterPublish:=False

' Not sure for what the Title is
Title = Range("K15")


' Define PDF filename
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & " " & Range("J1") & ".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 = Range("K17")
.To = Range("K5") ' <-- Put email of the recipient here
.CC = Range("K6") ' <-- Put email of 'copy to' recipient here
.Body = Range("K8") & vbLf & vbLf _
& Range("K9") & vbLf & vbLf _
& Range("K10") & vbLf & vbLf _
& Range("K11") & vbLf & vbLf _
& Range("K12") & vbLf & vbLf _
& Range("K13") & 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
Range("L25").Value = Range("L25").Value + 1

End Sub
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
.
Here is the corrected maco code. It works as expected here.

Code:
Option Explicit


Sub AttachActiveSheetPDFXX()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim SaveAsStr As String
'SaveAsStr = ActiveWorkbook.Path & "" & ActiveSheet.Range("J1").Value
SaveAsStr = ActiveSheet.Range("J1").Value




ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=SaveAsStr & ".pdf", _
OpenAfterPublish:=False


' Not sure for what the Title is
Title = Range("K15")




' Define PDF filename
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & " " & Range("J1") & ".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 = Range("K17").Value
.To = Range("K5").Value ' <-- Put email of the recipient here
.CC = Range("K6").Value ' <-- Put email of 'copy to' recipient here
.Body = Range("K8").Value & vbLf & vbLf _
& Range("K9").Value & vbLf & vbLf _
& Range("K10").Value & vbLf & vbLf _
& Range("K11").Value & vbLf & vbLf _
& Range("K12").Value & vbLf & vbLf _
& Range("K13").Value & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile


' Try to send
On Error Resume Next
.Display
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
Range("L25").Value = Range("L25").Value + 1


End Sub
 
Upvote 0

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top