Can anyone see what is going on with this VBA please? It allows us to display the email as .Display, but we're not able to automatically send with .Send. We have to keep .Send commented out.
Public Function SendEmails()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strBody As String
Dim strEmail As String
Dim strSubject As String
Dim db As Database
Dim rs As DAO.Recordset
Dim AttendeeSubject As String
Dim SchedClass As String
Dim StartTime As Integer
Dim strbody2 As String
Dim strbody3 As String
Dim SubjectHeader As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
Set db = CurrentDbSet rs = db.OpenRecordset("tempEmailSuccessfulRegistration", dbOpenDynaset)
If rs.RecordCount = 0 Then
MsgBox "No emails will be sent becuase there are no records assigned from the list", vbInformation
Else
With rs
While Not .EOF
Set OutMail = OutApp.CreateItem(olMailItem)
AttendeeSubject = rs("SubjectHeader") & " Class Registration: " & rs("Attendee")
strEmail = rs("emailaddress")
strSubject = AttendeeSubject
strBody = rs("Body1")
strbody2 = rs("Remember") & vbCrLf & vbCrLf
strbody3 = rs("Remember1")
'------------------------------------
'------------------------------------
'EMAIL REFORMAT - FOR WEBINARS
'------------------------------------
'------------------------------------
Dim myPos As Integer
Dim strPasscode As String
Dim strMeeting As String
Dim strChecklist As String
strChecklist = strChecklist & "</li></ol>"
strBody = strBody & strChecklist
'myPos = InStr(1, rs("ClassLocationRoom"), "P")
'strPasscode = Trim(Mid(rs("ClassLocationRoom"), myPos, 5000))
'strMeeting = Trim(Left(rs("ClassLocationRoom"), (myPos - 1)))
With OutMail
.To = strEmail
'.Subject = strSubject
.Subject = "TESTING - PLEASE DISREGARD"
.HTMLBody = strBody & rs("Body2") & "<br>" & "<br>" & strbody2 & "<br>" & "<br>" & strbody3 & "<br>" & "<br>" & rs("Respectfully")
.HTMLBody = .HTMLBody & "<br>" & "<br>" & "Class: " & rs("ClassName")
.HTMLBody = .HTMLBody & "<br>" & "Location: " & rs("ClassLocationat") & " "
.HTMLBody = .HTMLBody & "<br>" & "Address: " & rs("ClassLocationIn") & " "
.HTMLBody = .HTMLBody & "<br>" & "Room: " & rs("ClassLocationRoom") & " "
.HTMLBody = .HTMLBody & "<br>" & "Instructor: " & rs("ClassInstructor") & " "
.HTMLBody = .HTMLBody & "<br>" & strPasscode
.HTMLBody = .HTMLBody & "<br>" & strMeeting
.HTMLBody = .HTMLBody & "<br>" & "On: " & rs("classdate") & " at " & rs("starttime") & " " & rs("Classzone")
.Attachments.Add "N:\EVERYONE\MVL\Inspectors\InspectionManual\InspectionManual.pdf"
.Attachments.Add "N:\EVERYONE\MVL\Inspectors\Forms\TC 96-182.pdf"
'.Send
.Display
End With
On Error GoTo 0
rs.MoveNext
'------------------------------------
'-------------------------------------
Wend
End With
End If
On Error Resume
Next
rs.Close
Set rs = Nothing
Set db = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
End Function
We want to be able to automatically create and send emails with this code.
CodePudding user response：
The Outlook object model may trigger security prompts or throw errors when using unsafe methods and properties when Outlook is automated from other applications. See Protected Properties and Methods for the list the properties and methods in the Outlook object model that are protected by the Object Model Guard. If untrusted code performs a get on these properties or uses these methods, under default conditions for how Outlook is set up, it will invoke a security warning/issue.
To avoid security prompts/issues when dealing with OOM:
- use a low-level API on which Outlook is based on and which doesn't trigger security prompts
- use a third-party component which allows to turn off/on security warnings, see Outlook Security Manager for more information
- install the latest version of any antivirus software
- use group policy to change default settings
Finally, you may find the following articles helpful:
CodePudding user response：
I took the code and cut some stuff away, just to test it with less code. After fixing two lines
Set db = CurrentDbSet rs = db.OpenRecordset("tempEmailSuccessfulRegistration", dbOpenDynaset)
On Error Resume
Next
to:
Set db = CurrentDb
Set rs = db.OpenRecordset("tempEmailSuccessfulRegistration", dbOpenDynaset)
On Error Resume Next
The program runs ok with no errors and send all emails with data from the table.
Here is the code I used:
Public Function SendEmails()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strBody As String
Dim strEmail As String
Dim strSubject As String
Dim db As Database
Dim rs As DAO.Recordset
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
Set db = CurrentDb
Set rs = db.OpenRecordset("tempEmailSuccessfulRegistration", dbOpenDynaset)
If rs.RecordCount = 0 Then
MsgBox "No emails will be sent becuase there are no records assigned from the list", vbInformation
Else
With rs
While Not .EOF
Set OutMail = OutApp.CreateItem(olMailItem)
strEmail = rs("emailaddress")
strBody = rs("Body1")
'------------------------------------
'EMAIL REFORMAT - FOR WEBINARS
'------------------------------------
With OutMail
.To = strEmail
.Subject = "TESTING - PLEASE DISREGARD"
.HTMLBody = strBody
.Send
End With
rs.MoveNext
Wend
End With
End If
'On Error Resume Next
rs.Close
Set rs = Nothing
Set db = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
End Function
Test the code and see if you can run it without errors!