I have this code that sends mass emails with attachments. It works 50% of the time. Sometimes it only sends 20 emails and other times only sends 5 emails then errors out.
Run-time error `-2147467259 (80004005)':
The Operation Failed
Can someone please help me with this? I really appreciate your help in advance!
——————————
Sub MassEmailer()
'wb pwd is Summer2019
'pwd is apple
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim Datahouse1() As Variant
Dim ListSize As Variant
Dim Counter1 As Variant
Dim Counter2 As Variant
'With UserForm1
'.PopUp = True
'.Display
'End With
ListSize = Application.Workbooks("MassEmailer.xlsm").Sheets("List").Range("B:B").Cells.SpecialCells(xlCellTypeConstants).Count
ReDim Datahouse1(1 To ListSize, 1 To 7)
For Counter1 = 1 To ListSize
For Counter2 = 1 To 7
Datahouse1(Counter1, Counter2) = Application.Workbooks("MassEmailer.xlsm").Sheets("List").Cells(Counter1, Counter2)
Next Counter2
Next Counter1
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Dim editor As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim Counter3 As Variant
Dim Attachment1 As Variant
Dim Attachment2 As Variant
Dim Attachment3 As Variant
Dim Attachment4 As Variant
Dim Attachment5 As Variant
Dim Attachment6 As Variant
Attachment1 = Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(2, 2)
Attachment2 = Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(3, 2)
Attachment3 = Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(4, 2)
Attachment4 = Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(5, 2)
Attachment5 = Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(6, 2)
Attachment6 = Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(7, 2)
Dim TemplateFileLocation As Variant
TemplateFileLocation = Application.Workbooks("MassEmailer.xlsm").Sheets("Template").Cells(2, 3)
Set App = New Word.Application
Dim doc As Word.Document
Set App = CreateObject("Word.Application")
App.Visible = True
For Counter3 = 2 To ListSize
If Len(Datahouse1(Counter3, 1)) <> 0 Then
Set objMail = objOutlook.CreateItem(0)
Set doc = App.Documents.Open(Filename:=TemplateFileLocation)
With doc.Content.Find
.Text = "$NAME$"
.Replacement.Text = Datahouse1(Counter3, 3)
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
'With objMail
'.editor.Content.Paste
'End With
End With
doc.Content.Copy
End If
'Set objMail = objOutlook.CreateItem(0)
With objMail
'On Error Resume Next
If Len(Datahouse1(Counter3, 1)) <> 0 Then
.To = Datahouse1(Counter3, 4)
.CC = Application.Workbooks("MassEmailer.xlsm").Sheets("ExtraCC").Cells(2, 2)
.Subject = Datahouse1(Counter3, 6)
.ReadReceiptRequested = True
.SentOnBehalfOfName = confidential email address
.BodyFormat = olFormatRichText
Set editor = .GetInspector.WordEditor
editor.Content.Paste
.Display
'.Body = .editor.Content.Paste
doc.Close SaveChanges:=wdDoNotSaveChanges
'.CC = Application.Workbooks("MassEmailer.xlsm").Sheets("Templates").Cells(4, 2)
'.OriginatorDeliveryReportRequested = True
End If
If Len(Attachment1) > 0 Then
.Attachments.Add Attachment1
End If
If Len(Attachment2) > 0 Then
.Attachments.Add Attachment2
End If
If Len(Attachment3) > 0 Then
.Attachments.Add Attachment3
End If
If Len(Attachment4) > 0 Then
.Attachments.Add Attachment4
End If
If Len(Attachment5) > 0 Then
.Attachments.Add Attachment5
End If
If Len(Attachment6) > 0 Then
.Attachments.Add Attachment6
End If
'& "TCR " & Month(Date) & " " & Year(Date) & ".xlsx"
If Len(Datahouse1(Counter3, 5)) <> 0 Then
.Send
End If
End With
'.Attachments.Add Environ("USERPROFILE") & "\Desktop\" & "TCR " & Month(Date) & " " & Year(Date) & ".xlsx"
'.Display
'With objMail
'End With
'Set objMail = Nothing
Next Counter3
'With objMail
'.cc = wb1.Worksheets("Macro Controls").Cells(2, 8) & ";" & wb1.Worksheets("Macro Controls").Cells(2, 9) & ";" & wb1.Worksheets("Macro Controls").Cells(2, 10) & ";" & wb1.Worksheets("Macro Controls").Cells(2, 11)
'End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
MsgBox "Job Done!"
End Sub
Sub GetFilePath1()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Attachment 1"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(2, 2) = FileSelected
End Sub
Sub GetFilePath2()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Attachment 2"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(3, 2) = FileSelected
End Sub
Sub GetFilePath3()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Attachment 3"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(4, 2) = FileSelected
End Sub
Sub GetFilePath4()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Attachment 4"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(5, 2) = FileSelected
End Sub
Sub GetFilePath5()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Attachment 5"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(6, 2) = FileSelected
End Sub
Sub GetFilePath6()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Attachment 6"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(7, 2) = FileSelected
End Sub
Sub GetFilePath7()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Template"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Template").Cells(2, 3) = FileSelected
End Sub
Run-time error `-2147467259 (80004005)':
The Operation Failed
Can someone please help me with this? I really appreciate your help in advance!
——————————
Sub MassEmailer()
'wb pwd is Summer2019
'pwd is apple
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim Datahouse1() As Variant
Dim ListSize As Variant
Dim Counter1 As Variant
Dim Counter2 As Variant
'With UserForm1
'.PopUp = True
'.Display
'End With
ListSize = Application.Workbooks("MassEmailer.xlsm").Sheets("List").Range("B:B").Cells.SpecialCells(xlCellTypeConstants).Count
ReDim Datahouse1(1 To ListSize, 1 To 7)
For Counter1 = 1 To ListSize
For Counter2 = 1 To 7
Datahouse1(Counter1, Counter2) = Application.Workbooks("MassEmailer.xlsm").Sheets("List").Cells(Counter1, Counter2)
Next Counter2
Next Counter1
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Dim editor As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim Counter3 As Variant
Dim Attachment1 As Variant
Dim Attachment2 As Variant
Dim Attachment3 As Variant
Dim Attachment4 As Variant
Dim Attachment5 As Variant
Dim Attachment6 As Variant
Attachment1 = Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(2, 2)
Attachment2 = Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(3, 2)
Attachment3 = Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(4, 2)
Attachment4 = Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(5, 2)
Attachment5 = Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(6, 2)
Attachment6 = Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(7, 2)
Dim TemplateFileLocation As Variant
TemplateFileLocation = Application.Workbooks("MassEmailer.xlsm").Sheets("Template").Cells(2, 3)
Set App = New Word.Application
Dim doc As Word.Document
Set App = CreateObject("Word.Application")
App.Visible = True
For Counter3 = 2 To ListSize
If Len(Datahouse1(Counter3, 1)) <> 0 Then
Set objMail = objOutlook.CreateItem(0)
Set doc = App.Documents.Open(Filename:=TemplateFileLocation)
With doc.Content.Find
.Text = "$NAME$"
.Replacement.Text = Datahouse1(Counter3, 3)
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
'With objMail
'.editor.Content.Paste
'End With
End With
doc.Content.Copy
End If
'Set objMail = objOutlook.CreateItem(0)
With objMail
'On Error Resume Next
If Len(Datahouse1(Counter3, 1)) <> 0 Then
.To = Datahouse1(Counter3, 4)
.CC = Application.Workbooks("MassEmailer.xlsm").Sheets("ExtraCC").Cells(2, 2)
.Subject = Datahouse1(Counter3, 6)
.ReadReceiptRequested = True
.SentOnBehalfOfName = confidential email address
.BodyFormat = olFormatRichText
Set editor = .GetInspector.WordEditor
editor.Content.Paste
.Display
'.Body = .editor.Content.Paste
doc.Close SaveChanges:=wdDoNotSaveChanges
'.CC = Application.Workbooks("MassEmailer.xlsm").Sheets("Templates").Cells(4, 2)
'.OriginatorDeliveryReportRequested = True
End If
If Len(Attachment1) > 0 Then
.Attachments.Add Attachment1
End If
If Len(Attachment2) > 0 Then
.Attachments.Add Attachment2
End If
If Len(Attachment3) > 0 Then
.Attachments.Add Attachment3
End If
If Len(Attachment4) > 0 Then
.Attachments.Add Attachment4
End If
If Len(Attachment5) > 0 Then
.Attachments.Add Attachment5
End If
If Len(Attachment6) > 0 Then
.Attachments.Add Attachment6
End If
'& "TCR " & Month(Date) & " " & Year(Date) & ".xlsx"
If Len(Datahouse1(Counter3, 5)) <> 0 Then
.Send
End If
End With
'.Attachments.Add Environ("USERPROFILE") & "\Desktop\" & "TCR " & Month(Date) & " " & Year(Date) & ".xlsx"
'.Display
'With objMail
'End With
'Set objMail = Nothing
Next Counter3
'With objMail
'.cc = wb1.Worksheets("Macro Controls").Cells(2, 8) & ";" & wb1.Worksheets("Macro Controls").Cells(2, 9) & ";" & wb1.Worksheets("Macro Controls").Cells(2, 10) & ";" & wb1.Worksheets("Macro Controls").Cells(2, 11)
'End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
MsgBox "Job Done!"
End Sub
Sub GetFilePath1()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Attachment 1"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(2, 2) = FileSelected
End Sub
Sub GetFilePath2()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Attachment 2"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(3, 2) = FileSelected
End Sub
Sub GetFilePath3()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Attachment 3"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(4, 2) = FileSelected
End Sub
Sub GetFilePath4()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Attachment 4"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(5, 2) = FileSelected
End Sub
Sub GetFilePath5()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Attachment 5"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(6, 2) = FileSelected
End Sub
Sub GetFilePath6()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Attachment 6"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Attachments").Cells(7, 2) = FileSelected
End Sub
Sub GetFilePath7()
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Template"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Application.Workbooks("MassEmailer.xlsm").Sheets("Template").Cells(2, 3) = FileSelected
End Sub