Link to home
Create AccountLog in
Avatar of creativefusion
creativefusionFlag for Australia

asked on

Access 2007 Send Individual Emails to Multiple Contacts Using OFT file from Outlook

Hi all,

I have an access 2007 contacts db that contains contact information and email addresses of over 10,000+ contacts.

What I want to do at any given time is to send each individual contact in my table a separate email from outlook using a predefined template that I have created called fb.OFT.

So essentially, I would open my contacts table using an open recordset, then for each contact ID, open the template, modify the subject and then send the email. Looping through each contact ID.

Any help available.

CF
Avatar of creativefusion
creativefusion
Flag of Australia image

ASKER

Just as a note, my oft file is located in the following location:

C:\Users\Shaun\AppData\Roaming\Microsoft\Templates\fb.oft

For future expansion, I also have the template properties stored in a templates table which stores the oft template id, name and full path of the file.

CF
ASKER CERTIFIED SOLUTION
Avatar of Scott McDaniel (EE MVE )
Scott McDaniel (EE MVE )
Flag of United States of America image

Link to home
membership
Create an account to see this answer
Signing up is free. No credit card required.
Create Account
No points please.

I can attest that vbMAPI is very useful for unattended efforts like this.  I have several clients that use it to send automated reports to both clients and senior management.
Hi LSM

Thanks for the excellent tips.

First, I would like to make it very clear that I cannot invest any capital on this solution so the single license for the API from everything access is not an option for me.

The project I am compiling is for my own marketing use and is not part of a company so we do not need to consider network security, admin rights and the typical IT constraints that we would face in everyday commercial environments.

With that said LSM, I am having a crack at this on my own with your help of course and seem to be getting somewhere. However, I am getting an error saying for "Loop without Do".

Would you be able to take a peek at it and see where I might be going wrong with it?

Function sendEmailCampaign(uTemplateID As Integer, uState As Long, uSubject As String, uContactStatus As Integer, _
Optional uMsgFlag, Optional uSendFlag)
'AUTHOR SHAUN WALTERS
'CREDITS: HELEN FEDEMMA, LSM CONSULTING
'LAST MODIFIED: 2012-11-13
'DESCRIPTION: SENDS CAMPAIGN EMAILS TO CONTACTS BASED ON THE SELECTED PARAMETERS
    
    Dim rst As DAO.Recordset
    Dim rs As New ADODB.Recordset
    Dim Conn As ADODB.Connection
    Set Conn = CurrentProject.AccessConnection
    Dim strSQL As String
        
    Dim OutApp As Object
    Dim NewMail As Object
    Dim MyItem
    Dim currentBody, currentSubject, myOlExp
    Dim newBody, newSubject
    Dim AttachFileCStart, AttachFileCEnd, AttachFilePath
    Dim vEmailTemplateFileName, vEmailTemplatePath, vTotalRecFound As Long
    Dim vAttachmentFileName, vAttachmentFolderPath, vAttachementType
        
    'Set OutApp = Outlook.Application
    
    'OPEN RECORDSET WITH ALL THE EMAIL ADDRESSES BASED ON CHOSEN PARAMETERS ->
    Set rst = CurrentDb.OpenRecordset("SELECT tblContacts.EmailAddress From tblContacts " & _
    "WHERE (((tblContacts.ContactStatus)=" & uContactStatus & ") AND ((tblContacts.StateCode)=" & uState & "))")
      
    Do While Not rst.EOF
    
        'RETRIEVING THE TEMPLATE ID AND FULL PATH ->
        strSQL = "SELECT * FROM tblTemplates WHERE (tblTemplates.ID = " & uTemplateID & ")"
        rs.Open strSQL, Conn, adOpenKeyset, adLockOptimistic
        vTotalRecFound = rs.RecordCount
        
        'IF TEMPLATE FOUND THEN LOAD IT ->
        If vTotalRecFound = 1 Then
            
            vEmailTemplatePath = rs.Fields("EmailTemplatePath")
            vEmailTemplateFileName = rs.Fields("EmailTemplateName")
            
            Set MyItem = OutApp.CreateItemFromTemplate(vEmailTemplatePath & "\" & vEmailTemplateFileName)
            
            Set rs = Nothing
            
            'SET FLAG VALUES ->
            If IsMissing(uMsgFlag) = True Then uMsgFlag = 0
            If IsMissing(uSendFlag) = True Then uSendFlag = 0
            
            'SET CURRENT BODY TO HTML ->
            currentBody = NewMail.HTMLBody
            
            'INSERTING RECEIVER ADDRESS ->
            MyItem.To = rst("EmailField")
            
            'INSERTING SUBJECT ->
            MyItem.Subject = " & uSubject & "
                        
            'MyItem.HTMLBody = "Your body here"
                        
            If uMsgFlag = 1 Then NewMail.Display
                
                'SET BODY FORMAT TO RICH TEXT olFormatRichText = 3 ->
                NewMail.BodyFormat = 2
        
                'SAVE EMAIL ->
                NewMail.Save
        
                'SEND MAIL ONLY IF MSG FLAG IS = 1 ->
                If uSendFlag = 1 Then
                    MyItem.Send
                End If
                
                'RESET EVERYTHING BACK TO NOTHING ->
                Set NewMail = Nothing
                Set OutApp = Nothing
                    
        rst.MoveNext
    Loop
    
    'CLOSE DB
    Set rs = Nothing
    Set rst = Nothing
    
End Function

Open in new window

Also, I note that Helen Feddema has quite a bit of experience with outlook in this area as well. I was one of her beta testers for her most recent book however, her book does not address the solution that I am seeking. Helen, if you are reading this post, I would greatly appreciate your feedback as well.
You don't have an End If for the first IF statement. Looks like it should be here:

            'RESET EVERYTHING BACK TO NOTHING ->
                Set NewMail = Nothing
                Set OutApp = Nothing
END IF

But I'm not sure if those should be inside or outside of the code block.
Not sure where this is going now but I am really struggling with this.

Here is the code I have so far which seems to work fine up until line 70 onwards. However, I am not getting any error messages which is very strange????

Option Compare Database
Option Explicit
Private appOutlook As Outlook.Application
Private fld As Outlook.MAPIFolder
Private intResult As Integer
Private intReturn As Integer
Private lngDataType As Long
Private nms As Outlook.NameSpace
Private prj As Object
Private strAssignedTo As String
Private strCompanyName As String
Private strEmail As String
Private strFolderPath As String
Private strPrompt As String
Private strPropertyName As String
Private strTitle As String

Public Function sendEmailCampaign(uTemplateID As Integer, uState As Long, uSubject As String, uContactStatus As Integer, _
Optional uMsgFlag, Optional uSendFlag)
'AUTHOR SHAUN WALTERS
'CREDITS: HELEN FEDEMMA, LSM CONSULTING
'LAST MODIFIED: 2012-11-13
'DESCRIPTION: SENDS CAMPAIGN EMAILS TO CONTACTS BASED ON THE SELECTED PARAMETERS
    
    Dim rst As DAO.Recordset
    Dim rs As New ADODB.Recordset
    Dim Conn As ADODB.Connection
    Set Conn = CurrentProject.AccessConnection
    Dim strSQL As String
        
    Dim msg As Outlook.MailItem
    Dim fldDrafts As Outlook.Folder
        
    Dim OutApp As Object
    Dim NewMail As Object
    Dim MyItem
    Dim currentBody, currentSubject
    Dim newBody, newSubject
    Dim AttachFileCStart, AttachFileCEnd, AttachFilePath
    Dim vEmailTemplateFileName, vEmailTemplatePath, vTotalRecFound As Long
    Dim vAttachmentFileName, vAttachmentFolderPath, vAttachementType
        
    'OPEN RECORDSET WITH ALL THE EMAIL ADDRESSES BASED ON CHOSEN PARAMETERS ->
    Set rst = CurrentDb.OpenRecordset("SELECT tblContacts.EmailAddress From tblContacts " & _
    "WHERE (((tblContacts.ContactStatus)=" & uContactStatus & ") AND ((tblContacts.StateCode)=" & uState & "))")
    
    Do While Not rst.EOF
    
        'COLLECT EMAIL ADDRESS =>
        strEmail = rst("EmailAddress")
        
        
        'RETRIEVING THE TEMPLATE ID AND FULL PATH ->
        strSQL = "SELECT * FROM tblTemplates WHERE (tblTemplates.ID = " & uTemplateID & ")"
        rs.Open strSQL, Conn, adOpenKeyset, adLockOptimistic
                    
            vEmailTemplatePath = rs.Fields("EmailTemplatePath")
            vEmailTemplateFileName = rs.Fields("EmailTemplateName")
                        
            'CONFIRM SENDING EMAIL STRAIGHT AWAY OR STORE IN DRAFT FOLDER =>
            strTitle = "Question"
            strPrompt = "Send emails immediately?"
            intReturn = MsgBox(prompt:=strPrompt, _
               Buttons:=vbQuestion + vbYesNo, _
               Title:=strTitle)
     
            Set appOutlook = Outlook.Application
     
                If strEmail <> "" Then
                    If intReturn = vbYes Then
                        'Set appOutlook = appOutlook.CreateItemFromTemplate(vEmailTemplatePath & "\" & vEmailTemplateFileName)
                       Set appOutlook = GetObject(, "Outlook.Application")
                       Set msg = appOutlook.CreateItemFromTemplate(vEmailTemplatePath & "\" & vEmailTemplateFileName)
                      
                    Else
                       Set nms = appOutlook.GetNamespace("MAPI")
                       Set fldDrafts = nms.GetDefaultFolder(olFolderDrafts)
                       Set msg = fldDrafts.Items.Add(olMailItem)

                    End If
                End If
     
     strTitle = "Done"
     
     If strEmail <> "" Then
        If intReturn = vbYes Then
           strPrompt = "Email sent to " & strEmail
        Else
           strPrompt = "Email created in Drafts folder to " & strEmail
        End If
     End If
     
     MsgBox prompt:=strPrompt, _
        Buttons:=vbInformation + vbOKOnly, _
        Title:=strTitle
                    
        rst.MoveNext
    Loop
    
    'CLOSE DB
    Set rs = Nothing
    Set rst = Nothing
    
End Function

Open in new window

Added msg.send and cleaned it up a bit for legibility purposes. Any help is greatly appreciated guys. CF

Public Function sendEmailCampaign(uTemplateID As Integer, uState As Long, uSubject As String, uContactStatus As Integer, _
Optional uMsgFlag, Optional uSendFlag)
'AUTHOR SHAUN WALTERS
'CREDITS: HELEN FEDEMMA, LSM CONSULTING
'LAST MODIFIED: 2012-11-13
'DESCRIPTION: SENDS CAMPAIGN EMAILS TO CONTACTS BASED ON THE SELECTED PARAMETERS
    
    Dim rst As DAO.Recordset
    Dim rs As New ADODB.Recordset
    Dim Conn As ADODB.Connection
    Set Conn = CurrentProject.AccessConnection
    Dim strSQL As String
        
    Dim msg As Outlook.MailItem
    Dim fldDrafts As Outlook.Folder
        
    Dim OutApp As Object
    Dim NewMail As Object
    Dim MyItem
    Dim currentBody, currentSubject
    Dim newBody, newSubject
   
    Dim vEmailTemplateFileName, vEmailTemplatePath, vTotalRecFound As Long
            
    'OPEN RECORDSET WITH ALL THE EMAIL ADDRESSES BASED ON CHOSEN PARAMETERS ->
    Set rst = CurrentDb.OpenRecordset("SELECT tblContacts.EmailAddress From tblContacts " & _
    "WHERE (((tblContacts.ContactStatus)=" & uContactStatus & ") AND ((tblContacts.StateCode)=" & uState & "))")
    
    'SPECIFYING LOOP ->
    Do While Not rst.EOF
    
        'COLLECT EMAIL ADDRESS =>
        strEmail = rst("EmailAddress")
                
        'RETRIEVING THE TEMPLATE ID AND FULL PATH ->
        strSQL = "SELECT * FROM tblTemplates WHERE (tblTemplates.ID = " & uTemplateID & ")"
        rs.Open strSQL, Conn, adOpenKeyset, adLockOptimistic
                    
            vEmailTemplatePath = rs.Fields("EmailTemplatePath")
            vEmailTemplateFileName = rs.Fields("EmailTemplateName")
                        
            'SET RS TO NOTHING
            Set rs = Nothing
            
            'CONFIRM SENDING EMAIL STRAIGHT AWAY OR STORE IN DRAFT FOLDER =>
            strTitle = "Question"
            strPrompt = "Send emails immediately?"
            intReturn = MsgBox(prompt:=strPrompt, _
               Buttons:=vbQuestion + vbYesNo, _
               Title:=strTitle)
            
            'SET OUTLOOK ->
            Set appOutlook = GetObject(, "Outlook.Application")
                
                'VALIDATE EMAIL ADDRESS ->
                If strEmail <> "" Then
                    If intReturn = vbYes Then
                        Set msg = appOutlook.CreateItemFromTemplate(vEmailTemplatePath & "\" & vEmailTemplateFileName)
                        msg.Send
                    Else
                        Set nms = appOutlook.GetNamespace("MAPI")
                        Set fldDrafts = nms.GetDefaultFolder(olFolderDrafts)
                        Set msg = fldDrafts.Items.Add(olMailItem)
                    End If
                End If
     
        rst.MoveNext
    Loop
    
    'CLOSE DB
    Set rs = Nothing
    Set rst = Nothing
    
End Function

Open in new window

If you set a breakpoint at line 70, what happens as you step through the code? Do you encounter errors on any other lines?

Are you sure that vEmailTemplatePath and vEmailTemplateFileName return the correct values, and that you concatenate them correctly?
I managed to resolve this myself after a fair bit of research. Here is my completed code which works fine.

Public Function sendEmailCampaign(uTemplateID As Integer, uState As Integer, uContactStatus As Integer, _
uSendFlag As Integer)
'AUTHOR SHAUN WALTERS
'CREDITS: HELEN FEDEMMA, LSM CONSULTING
'LAST MODIFIED: 2012-11-13
'DESCRIPTION: SENDS CAMPAIGN EMAILS TO CONTACTS BASED ON THE SELECTED PARAMETERS
    
    Dim rst As DAO.Recordset
    Dim rs As New ADODB.Recordset
    Dim Conn As ADODB.Connection
    Set Conn = CurrentProject.AccessConnection
    Dim strSQL As String
        
    Dim msg As Outlook.MailItem
    Dim fldDrafts As Outlook.Folder
        
    Dim OutApp As Object
    Dim NewMail As Object
    Dim MyItem
    Dim currentBody, currentSubject
    Dim newBody, newSubject
   
    Dim vEmailTemplateFileName, vEmailTemplatePath
            
    If uState > 0 Then
        'OPEN RECORDSET WITH ALL THE EMAIL ADDRESSES BASED ON CHOSEN PARAMETERS ->
        Set rst = CurrentDb.OpenRecordset("SELECT tblContacts.EmailAddress From tblContacts " & _
        "WHERE (((tblContacts.ContactStatus)=" & uContactStatus & ") AND ((tblContacts.StateCode)=" & uState & "))")
    Else
        'OPEN RECORDSET WITH ALL THE EMAIL ADDRESSES BASED ON CHOSEN PARAMETERS ->
        Set rst = CurrentDb.OpenRecordset("SELECT tblContacts.EmailAddress From tblContacts " & _
        "WHERE (((tblContacts.ContactStatus)=" & uContactStatus & "))")
    End If
    
    'SPECIFYING LOOP ->
    Do While Not rst.EOF
    
        'COLLECT EMAIL ADDRESS =>
        strEmail = rst("EmailAddress")
                
        'RETRIEVING THE TEMPLATE ID AND FULL PATH ->
        strSQL = "SELECT * FROM tblTemplates WHERE (tblTemplates.ID = " & uTemplateID & ")"
        rs.Open strSQL, Conn, adOpenKeyset, adLockOptimistic
                   
            'COLLECTING THE TEMPLATE FILE DETAILS FROM THE RECORDSET ->
            vEmailTemplatePath = rs.Fields("EmailTemplatePath")
            vEmailTemplateFileName = rs.Fields("EmailTemplateName")
                        
            'SET RS TO NOTHING
            Set rs = Nothing
                        
            'SET OUTLOOK ->
            Set appOutlook = GetObject(, "Outlook.Application")
                
                'VALIDATE EMAIL ADDRESS ->
                If strEmail <> "" Then
                    If uSendFlag = vbYes Then
                        Set msg = appOutlook.CreateItemFromTemplate(vEmailTemplatePath & "\" & vEmailTemplateFileName)
                        msg.To = strEmail
                        'MODIFY THE FOLLOWING POSSIBLE EXPANSIONS AS REQUIRED (S.WALTERS)
                        'msg.Subject = strSubject
                        'msg.Body = strMessage
                        msg.Send
                    Else
                        Set nms = appOutlook.GetNamespace("MAPI")
                        Set fldDrafts = nms.GetDefaultFolder(olFolderDrafts)
                        Set msg = fldDrafts.Items.Add(olMailItem)
                    End If
                End If
     
        rst.MoveNext
    Loop
    
    'CLOSE DB
    Set rs = Nothing
    Set rst = Nothing
    Set appOutlook = Nothing
    Set msg = Nothing
        
End Function

Open in new window

Great help thanks LSM.