Emailing multiple query results using VBA Access 2007

Question

Hello everyone I am new to programming in VBA and have been at it for a week. I am trying to learn to write my own code but I have come up with a issue.

My end result is that I send one email to all my vendors with their names in the BCC field. My current code creates a email for each contact which is not needed. I am sure this is a simple fix but here is my code so far. I appreciate your help!

 Private Sub Compose_Button_Click()

Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.mailItem
Dim objOultlookRecip As Outlook.Recipients
Dim objOutlookAttach As Outlook.Attachments
Dim TheAddress As String

Set db = CurrentDb
Set rst = Me.Recordset
rst.MoveFirst

Set objOutlook = CreateObject("Outlook.Application")

Do Until rst.EOF

'Create Email message

Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
TheAddress = rst![E-Mail]

    With objOutlookMsg
    Set objOutlookRecip = .Recipients.Add(TheAddress)
    objOutlookRecip.Type = olBCC

objOutlookMsg.Display

End With

rst.MoveNext

Loop
   Set objOutlookMsg = Nothing
   Set objOutlook = Nothing


End Sub

Thank you!!

score 0 · Answer 1 · answered Oct 21 '13 at 18:51

If all you need is to assemble a list of unique email addresses then you could loop through (a clone of) the Form's Recordset and stuff the values into a Dictionary object, then iterate through the Dictionary to send the emails. That would go something like this:

Option Compare Database
Option Explicit

Private Sub Command0_Click()
Dim rst As DAO.Recordset
Dim EmailAddresses As Object  ' Dictionary
Dim EmailAddress As Variant

Set rst = Me.RecordsetClone
If Not (rst.EOF And rst.BOF) Then
    rst.MoveFirst
    Set EmailAddresses = CreateObject("Scripting.Dictionary")  ' New Dictionary
    Do Until rst.EOF
        If Not IsNull(rst("E-mail").Value) Then
            If Not EmailAddresses.Exists(rst("E-mail").Value) Then
                EmailAddresses.Add rst("E-mail").Value, ""
            End If
        End If
        rst.MoveNext
    Loop
    For Each EmailAddress In EmailAddresses.Keys
        ' send your email to EmailAddress here
    Next
    Set EmailAddresses = Nothing
End If
Set rst = Nothing
End Sub

Emailing multiple query results using VBA Access 2007

1 Answers1