I have written VBA code which sends out emails with customised attachments to all addressees in an Access 2010 table. The person sending this emails has multiple Outlook accounts. I have tried using the .sendusingaccount feature but I keep getting errors. Can anyone help?
Code:
Dim dbName As Database
Dim rst As Recordset
Dim zWhere As String
Dim zMsgBody As String
Dim zEmail As String
Dim zFirstname As String
Dim zSubject As String
Dim zMessage As String
Dim zDocname As String
Dim olApp As outlook.Application
Dim olMail As outlook.MailItem
Dim objOutlookAttach As outlook.Attachment
Dim dbs As DAO.Database
Dim rsSQL As DAO.Recordset
Dim strSQL As String
Dim eMailSubject As String
Dim eMailContent As String
Dim Attachment1 As String
Dim Attachment2 As String
Dim Attachment3 As String
eMailSubject = DLookup("[eMailSubject]", "[FileLocations]", "[RecordNumber] = 1")
eMailContent = DLookup("[eMailContent]", "[FileLocations]", "[RecordNumber] = 1")
Attachment1 = DLookup("[Attachment1]", "[FileLocations]", "[RecordNumber] = 1")
Attachment2 = DLookup("[Attachment2]", "[FileLocations]", "[RecordNumber] = 1")
Attachment3 = DLookup("[Attachment3]", "[FileLocations]", "[RecordNumber] = 1")
Set olApp = New outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
Set dbName = CurrentDb()
Set rst = dbName.OpenRecordset("GroupLeaderEmail")
zDocname = "GroupMembership"
rst.MoveFirst
Do While Not rst.EOF
If (Me.Frame7 = 1 And rst!AlphaGroup Like "[A-D]") Or (Me.Frame7 = 2 And rst!AlphaGroup Like "[E-K]") Or (Me.Frame7 = 3 And rst!AlphaGroup Like "[L-R]") Or (Me.Frame7 = 4 And rst!AlphaGroup Like "[S-Z]") Or Me.Frame7 = 5 Then
zWhere = "[GroupCode] = " & Chr(34) & (rst![GroupCode]) & Chr(34)
zFirstname = rst![FirstName]
DoCmd.OpenReport zDocname, acPreview, , zWhere
DoCmd.OutputTo acReport, , acFormatRTF, Attachment3, False
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.BodyFormat = olFormatHTML
.To = rst![PrivateEMail]
.CC = ""
.Subject = eMailSubject
.Body = "Dear " & zFirstname & vbNewLine & vbNewLine & eMailContent
olMail.Attachments.Add Attachment1
olMail.Attachments.Add Attachment2
olMail.Attachments.Add Attachment3
.Save
.Send
End With
Kill ("C:\Users\Peter\Documents\GroupMembership.rtf")
DoCmd.Close acReport, zDocname
End If
rst.MoveNext '*** Move to Next Record ***
Loop
Set rst = Nothing '*** Close RecordSet ***
Set olMail = Nothing
Set objOutlookAttach = Nothing
Set olApp = Nothing
Set rstAttachments = Nothing
Set db = Nothing
End Sub