Hi,
I have been using the following code for a number of months without any issue, but recently it has stopped working and displays the following error;
Run-time error 429
ActiveX component cant create object
When i step into the code to debug the following is highlighted
"Set OutApp = CreateObject("Outlook.Application")"
For context the document was created to be able to send important reminder emails at 90 days, 60 days & 30 days directly from excel extracting the important information required and sending only to the individual recipient
I am running on O365 - Please can someone help??
Richard
Sub Automate()
Call Day30
Call Day60
Call Day90
Call CRBExpired
End Sub
Sub Day30()
Dim OutApp As Object
Dim OutMail As Object
Dim Mailcount As Integer
Dim i As Integer
Dim FindValue As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Mailcount = Sheets("30 - 1 Day").Range("M1").Value
If Mailcount = 0 Then Exit Sub
For x = 2 To Sheets("30 - 1 Day").Range("M1").Value Step 1
Sheets("30 - 1 Day").Range("M2").Formula = "=B" & x
Sheets("30 - 1 Day").Range("M3").Formula = "=E" & x
Sheets("30 - 1 Day").Range("M4").Formula = "=C" & x
Sheets("30 - 1 Day").Range("M5").Formula = "=D" & x
Dim ContactName As String
ContactName = Sheets("30 - 1 Day").Range("M2").Value
Dim ContactEmail As String
ContactEmail = Sheets("30 - 1 Day").Range("M3").Value
Dim DBSExpiry As String
DBSExpiry = Sheets("30 - 1 Day").Range("M4").Value
Dim DaysRemaining As String
DaysRemaining = Sheets("30 - 1 Day").Range("M5").Value
Dim SoBo As String
SoBo = Sheets("30 - 1 Day").Range("M5").Value
'Set Outlook Mail Variables
Set OutApp = CreateObject("Outlook.Application")
'Set OutMail = OutApp.CreateItem(0)
'Set olApp = Outlook.Application
'Create e-mail item
'Set objMail = olApp.CreateItem(olMailItem)
With OutMail
.To = ContactEmail
.SentOnBehalfOfName = SoBo
.Subject = "Birmingham County FA - URGENT Action Required 30 Day DBS Renewal Notice"
.body = "Hi " & ContactName & vbCr & _
" " & vbCr & _
"Birmingham County FA have identified that your DBS is due for renewal in " & DaysRemaining & " days" & vbCr & _
" " & vbCr & _
"You need to ensure you have spoken to your club to complete this renewal before the expiration date" & vbCr & _
"" & vbCr & _
"Please Note: Under regulations if you fail to hold an in date DBS you will be suspended from your role within football" & vbCr & _
"" & vbCr & _
"The timeline for checks to be completed can be up to 90 days, so please make sure you action this at your earliest convenience" & vbCr & _
"" & vbCr & _
"If you believe you hold an in date DBS check then please contact the County FA directly via the below email to investigate further" & vbCr & _
"" & vbCr & _
"Email: Safeguarding@BirminghamFA.com" & vbCr & _
"" & vbCr & _
"" & vbCr & _
"Kind Regards Birmingham County FA"
.Display
End With
Next
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub Day60()
Dim OutApp As Object
Dim OutMail As Object
Dim Mailcount As Integer
Dim i As Integer
Dim FindValue As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Mailcount = Sheets("60 - 31 Day").Range("M1").Value
If Mailcount = 0 Then Exit Sub
For x = 2 To Sheets("60 - 31 Day").Range("M1").Value Step 1
Sheets("60 - 31 Day").Range("M2").Formula = "=B" & x
Sheets("60 - 31 Day").Range("M3").Formula = "=E" & x
Sheets("60 - 31 Day").Range("M4").Formula = "=C" & x
Sheets("60 - 31 Day").Range("M5").Formula = "=D" & x
Dim ContactName As String
ContactName = Sheets("60 - 31 Day").Range("M2").Value
Dim ContactEmail As String
ContactEmail = Sheets("60 - 31 Day").Range("M3").Value
Dim DBSExpiry As String
DBSExpiry = Sheets("60 - 31 Day").Range("M4").Value
Dim DaysRemaining As String
DaysRemaining = Sheets("60 - 31 Day").Range("M5").Value
Dim SoBo As String
SoBo = Sheets("30 - 1 Day").Range("M5").Value
Set OutApp = CreateObject("Outlook.Application")
'Set Outlook Mail Variables
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = SoBo
.To = ContactEmail
.Subject = "Birmingham County FA - URGENT Action Required 60 Day DBS Renewal Notice"
.body = "Hi " & ContactName & vbCr & _
" " & vbCr & _
"Birmingham County FA have identified that your DBS is due for renewal in " & DaysRemaining & " days" & vbCr & _
" " & vbCr & _
"You need to ensure you have spoken to your club to complete this renewal before the expiration date" & vbCr & _
"" & vbCr & _
"Please Note: Under regulations if you fail to hold an in date DBS you will be suspended from your role within football" & vbCr & _
"" & vbCr & _
"The timeline for checks to be completed can be up to 90 days, so please make sure you action this at your earliest convenience" & vbCr & _
"" & vbCr & _
"If you believe you hold an in date DBS check then please contact the County FA directly via the below email to investigate further" & vbCr & _
"" & vbCr & _
"Email: Safeguarding@BirminghamFA.com" & vbCr & _
"" & vbCr & _
"" & vbCr & _
"Kind Regards Birmingham County FA"
.Display
End With
Next
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub Day90()
Dim OutApp As Object
Dim OutMail As Object
Dim Mailcount As Integer
Dim i As Integer
Dim FindValue As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Mailcount = Sheets("90 - 61 Day").Range("M1").Value
If Mailcount = 0 Then Exit Sub
For x = 2 To Sheets("90 - 61 Day").Range("M1").Value Step 1
Sheets("90 - 61 Day").Range("M2").Formula = "=B" & x
Sheets("90 - 61 Day").Range("M3").Formula = "=E" & x
Sheets("90 - 61 Day").Range("M4").Formula = "=C" & x
Sheets("90 - 61 Day").Range("M5").Formula = "=D" & x
Dim ContactName As String
ContactName = Sheets("90 - 61 Day").Range("M2").Value
Dim ContactEmail As String
ContactEmail = Sheets("90 - 61 Day").Range("M3").Value
Dim DBSExpiry As String
DBSExpiry = Sheets("90 - 61 Day").Range("M4").Value
Dim DaysRemaining As String
DaysRemaining = Sheets("90 - 61 Day").Range("M5").Value
Dim SoBo As String
SoBo = Sheets("30 - 1 Day").Range("M5").Value
Set OutApp = CreateObject("Outlook.Application")
'Set Outlook Mail Variables
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = SoBo
.To = ContactEmail
.Subject = "Birmingham County FA - URGENT Action Required 90 Day DBS Renewal Notice"
.body = "Hi " & ContactName & vbCr & _
" " & vbCr & _
"Birmingham County FA have identified that your DBS is due for renewal in " & DaysRemaining & " days" & vbCr & _
" " & vbCr & _
"You need to ensure you have spoken to your club to complete this renewal before the expiration date" & vbCr & _
"" & vbCr & _
"Please Note: Under regulations if you fail to hold an in date DBS you will be suspended from your role within football" & vbCr & _
"" & vbCr & _
"The timeline for checks to be completed can be up to 90 days, so please make sure you action this at your earliest convenience" & vbCr & _
"" & vbCr & _
"If you believe you hold an in date DBS check then please contact the County FA directly via the below email to investigate further" & vbCr & _
"" & vbCr & _
"Email: Safeguarding@BirminghamFA.com" & vbCr & _
"" & vbCr & _
"" & vbCr & _
"Kind Regards Birmingham County FA"
.Display
End With
Next
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub CRBExpired()
Dim OutApp As Object
Dim OutMail As Object
Dim Mailcount As Integer
Dim i As Integer
Dim FindValue As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Mailcount = Sheet8.Range("M1").Value
If Mailcount = 0 Then Exit Sub
For x = 2 To Sheets("CRB Expired").Range("M1").Value Step 1
Sheets("CRB Expired").Range("M2").Formula = "=B" & x
Sheets("CRB Expired").Range("M3").Formula = "=E" & x
Sheets("CRB Expired").Range("M4").Formula = "=C" & x
Sheets("CRB Expired").Range("M5").Formula = "=D" & x
Dim ContactName As String
ContactName = Sheets("CRB Expired").Range("M2").Value
Dim ContactEmail As String
ContactEmail = Sheets("CRB Expired").Range("M3").Value
Dim DBSExpiry As String
DBSExpiry = Sheets("CRB Expired").Range("M4").Value
Dim DaysRemaining As String
DaysRemaining = Sheets("CRB Expired").Range("M5").Value
Dim SoBo As String
SoBo = Sheets("CRB Expired").Range("M6").Value
Set OutApp = CreateObject("Outlook.Application")
'Set Outlook Mail Variables
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = SoBo
.To = ContactEmail
.Subject = "Birmingham County FA - URGENT Action Required DBS Expired"
.body = "Hi " & Sheet8.Range("B2").Text & vbCr & _
" " & vbCr & _
"Birmingham County FA have identified that your DBS expired " & DaysPast & " days ago" & vbCr & _
" " & vbCr & _
"You need to ensure you have spoken to your club to complete this renewal before the expiration date" & vbCr & _
"" & vbCr & _
"Please Note: Under regulations failure to hold an in date and accepted FA DBS check which shows on your FAN record will result in suspension from your role within football after 21 days of the expiration date" & vbCr & _
"" & vbCr & _
"The timeline for checks to be completed can be up to 90 days, so please make sure you action this at your earliest convenience" & vbCr & _
"" & vbCr & _
"If you believe you hold an in date DBS check then please contact the County FA directly via the below email to investigate further" & vbCr & _
"" & vbCr & _
"Email: Safeguarding@BirminghamFA.com" & vbCr & _
"" & vbCr & _
"" & vbCr & _
"Kind Regards Birmingham County FA"
.Display
End With
Next
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub Mark60(FindValue As String)
Dim TblRow As Integer
Dim TblLen As Long
'Set Table Lenght
TblLen = Sheet2.Cells(Rows.Count, 1).End(xlUp).row
'Loop to Find Empty Date Out Space
For TblRow = 2 To TblLen
If Sheet2.Range("D" & TblRow) = FindValue And Sheet2.Range("Q" & TblRow) = "" Then
Sheet2.Range("Q" & TblRow) = "Email Sent" & Now
Exit Sub
End If
Next TblRow
End Sub
Sub Mark90(FindValue As String)
Dim TblRow As Integer
Dim TblLen As Long
'Set Table Lenght
TblLen = Sheet2.Cells(Rows.Count, 1).End(xlUp).row
'Loop to Find Empty Date Out Space
For TblRow = 2 To TblLen
If Sheet2.Range("D" & TblRow) = FindValue And Sheet2.Range("P" & TblRow) = "" Then
Sheet2.Range("P" & TblRow) = "Email Sent" & Now
Exit Sub
End If
Next TblRow
End Sub
Sub MarkCRBExpired(FindValue As String)
Dim TblRow As Integer
Dim TblLen As Long
'Set Table Lenght
TblLen = Sheet2.Cells(Rows.Count, 1).End(xlUp).row
'Loop to Find Empty Date Out Space
For TblRow = 2 To TblLen
If Sheet2.Range("D" & TblRow) = FindValue And Sheet2.Range("S" & TblRow) = "" Then
Sheet2.Range("S" & TblRow) = "Email Sent" & Now
Exit Sub
End If
Next TblRow
End Sub
