Hello,
I am attempting to forward emails, including attachments, based on the subject line. I have multiple subjects and the related email recipients in a control table. My VBA code runs without error, however it only sends the first record's email. I confirmed the one email get sent, but I need the code to move to the next record until end of control table forwarding multiple emails to multiple recipients. My code is below:
Code:
Option Compare Database
Option Explicit
Sub ForwardEmailswithaSpecificSubjects()
Dim objapp As Outlook.Application
Dim objns As Outlook.NameSpace
Set objns = Outlook.GetNamespace("MAPI")
Dim objCurrentFolder As Outlook.Folder
Dim objVariant As Variant
Dim objForwardMail As MailItem
Dim i As Long
Set Outlook.ActiveExplorer.CurrentFolder = objns.GetDefaultFolder(6)
Set objCurrentFolder = Outlook.ActiveExplorer.CurrentFolder
'Set Items = objns.GetDefaultFolder(olFolderInbox).Parent.Folders("Inbox").Items
Dim myRs As DAO.Recordset
Dim myRb As DAO.Recordset
Set myRs = CurrentDb().OpenRecordset("Email_List_Test")
Set myRb = CurrentDb().OpenRecordset("bodytext")
For i = objCurrentFolder.Parent.Folders("Inbox").Items.Count To 1 Step -1
If TypeOf objCurrentFolder.Items.Item(i) Is MailItem Then
Set objVariant = objCurrentFolder.Parent.Folders("Inbox").Items.Item(i)
Set objForwardMail = objVariant.Forward
'change the recipient email address as per your needs
'Use ; to connect several recipients
If myRs.RecordCount > 0 Then
myRs.MoveFirst
If objVariant.Subject = myRs![lookup_Subject] Then
With objForwardMail
.To = myRs![Email_Distribution_list]
.Subject = "Securemail: " + .Subject
.Body = myRb![bodyofemail]
.Send
myRs.MoveNext
End With
End If
End If
End If
Next i
End Sub