VBA run-time error

A

Aaro23

New Member
Joined
Dec 1, 2023
Messages
4
Office Version
  1. 2003 or older
Platform
  1. Windows
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
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Sort by date Sort by votes
This part here doesn't look right...
Code: 
Set App = New Word.Application
Dim doc As Word.Document
Set App = CreateObject("Word.Application")
You are using early binding and creating 2 Word applications. It should be...
Code: 
Dim App As Word.Application,  doc As Word.Document
Set App = New Word.Application
App.Visible = True
Set doc = App.Documents.Open(Filename:=TemplateFileLocation)
Not sure if this will fix your problem but it might help. Dave
 
Upvote 1
NdNoviceHlp said:
This part here doesn't look right...
Code: 
Set App = New Word.Application
Dim doc As Word.Document
Set App = CreateObject("Word.Application")
You are using early binding and creating 2 Word applications. It should be...
Code: 
Dim App As Word.Application,  doc As Word.Document
Set App = New Word.Application
App.Visible = True
Set doc = App.Documents.Open(Filename:=TemplateFileLocation)
Not sure if this will fix your problem but it might help. Dave
Click to expand...

Thank you Dave! I will try this and see if it fixes the error. Thank you for your help once again! :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
Option buttons not clickable after running VBA export code
Replies
2
Views
333
Domenic
D
C
  • Question Question
VBA code stuck (extract data from worksheet)
Replies
1
Views
396
Alex Blakenburg
A
L
  • Question Question
Error when cancelling a pop up box
Replies
4
Views
207
dmt32
D
larinda4
  • Question Question
VBA: Send Outlook Email & Attach PDF
Replies
1
Views
613
Trebor76
T
L
  • Question Question
CDO_Mail_Small_Text Run time error
Replies
0
Views
123
Louis chiron
L

Forum statistics

Threads
1,223,886
Messages
6,175,198
Members
452,616
Latest member
intern444

Share this page

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