How can you transfer email addresses within an Access 2013 T or Q to Outlook 2013 contacts or email?

[LovellDC]

I have created a db in Access 2013 and want to transfer some of the email addresses into outlook to send a blanket email, does anyone know how to do this using Access 2013 and Outlook 2013 without exporting it to excel first?

Thanks

[John_G]

Here is some code you might find useful. As I recall I found it on this website, and I was able to make it work.

Option Compare Database
Option Explicit
Sub AddToList(ListName As String, ContactName As String, Optional AList As Boolean = True)
On Error Resume Next
    Dim myOlApp As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myDistList As Outlook.DistListItem
    Dim myTempItem As Outlook.MailItem
    Dim myRecipients As Outlook.Recipients
    Dim objcontacts As Outlook.MAPIFolder
    Dim objcontact As Outlook.ContactItem
    Dim myid, myname As String
    
If AList = True Then 'if true add, if not remove
    'check to see if list already exists
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set myDistList = objcontacts.Items("" & ListName)
    If Err.Number = -2147221233 Then
      GoTo Createmylist
      Err.Clear
    Else
      GoTo AddToList
    End If
    Exit Sub
    
    
Createmylist:
'    myid = frm.IDContact
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myTempItem = myOlApp.CreateItem(olMailItem)
    Set myRecipients = myTempItem.Recipients
    Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set objcontact = objcontacts.Items.Find("[user1] =" & myid)
    Set myDistList = myOlApp.CreateItem(olDistributionListItem)
    
    myname = objcontact.FullName
    myDistList.DLName = "" & ListName
    myRecipients.Add "" & myname
    myRecipients.ResolveAll
    myDistList.AddMembers myRecipients
    myDistList.Close olSave
    GoTo mycleanup
    
    
AddToList:
'    myid = frm.IDContact
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myTempItem = myOlApp.CreateItem(olMailItem)
    Set myRecipients = myTempItem.Recipients
    Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set objcontact = objcontacts.Items.Find("[user1] =" & myid)
    Set myDistList = objcontacts.Items("" & ListName)
    myname = objcontact.FullName
    myRecipients.Add "" & myname
    myRecipients.ResolveAll
    myDistList.AddMembers myRecipients
    myDistList.Close olSave
   GoTo mycleanup
   
Else ' remove in unchecked
'check to see if list already exists
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set myDistList = objcontacts.Items("" & ListName)
    If Err.Number = -2147221233 Then
      Err.Clear
      Exit Sub
    Else
'      myid = frm.IDContact
      Set myOlApp = CreateObject("Outlook.Application")
      Set myNameSpace = myOlApp.GetNamespace("MAPI")
      Set myTempItem = myOlApp.CreateItem(olMailItem)
      Set myRecipients = myTempItem.Recipients
      Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
      Set objcontact = objcontacts.Items.Find("[user1] =" & myid)
      Set myDistList = objcontacts.Items("" & ListName)
    End If
    myname = objcontact.FullName
    myRecipients.Add "" & myname
    myRecipients.ResolveAll
    myDistList.RemoveMembers myRecipients
    myDistList.Close olSave
   
   
   'check to see if list is populated, delete if empty
   If myDistList.MemberCount = 0 Then
   myDistList.Delete
   End If
   
End If

mycleanup:
    Set myOlApp = Nothing
    Set myNameSpace = Nothing
    Set myDistList = Nothing
    Set myTempItem = Nothing
    Set myRecipients = Nothing
    Set objcontacts = Nothing
    Set objcontact = Nothing
    
    
End Sub
Sub CreateList(ListName As String)
    On Error GoTo ProcErr
    Dim myOlApp As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myDistList As Outlook.DistListItem
    Dim myTempItem As Outlook.MailItem
    Dim myRecipients As Outlook.Recipients
    Dim objcontacts As Outlook.MAPIFolder
    Dim objcontact As Outlook.ContactItem
    Dim myid, myname As String
    
    
'    myid = frm.IDContact
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myTempItem = myOlApp.CreateItem(olMailItem)
    Set myRecipients = myTempItem.Recipients
    Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set objcontact = objcontacts.Items.Find("[user1] =" & myid)
    Set myDistList = myOlApp.CreateItem(olDistributionListItem)
    
    myname = objcontact.FullName
    myDistList.DLName = "" & ListName
    myRecipients.Add "" & myname
    myRecipients.ResolveAll
    myDistList.AddMembers myRecipients
    myDistList.Close olSave
    GoTo mycleanup
    
mycleanup:
    Set myOlApp = Nothing
    Set myNameSpace = Nothing
    Set myDistList = Nothing
    Set myTempItem = Nothing
    Set myRecipients = Nothing
    Set objcontacts = Nothing
    Set objcontact = Nothing
    
    Exit Sub
ProcErr:
  MsgBox Err.Description
  Err.Clear
  GoTo mycleanup
End Sub
Function AddOlContact()
On Error GoTo Error_Handler
    Const olContactItem = 2
    Dim olApp As Object
    Dim Ctct As Object
    Dim olcontact
 
    Set olApp = CreateObject("Outlook.Application")
    Set olcontact = olApp.CreateItem(olContactItem)
 
    With olcontact
        .FirstName = "Daniel"
        .LastName = "Alba"
        .JobTitle = ""
        .CompanyName = "MINI CARDA"
        .BusinessAddressStreet = "22 ClearPoint"
        .BusinessAddressCity = "Pointe-Claire"
        .BusinessAddressState = "Quebec"
        .BusinessAddressCountry = "Canada"
        .BusinessAddressPostalCode = "H9X 3A6"
        .BusinessTelephoneNumber = "(514) 488-0956"
        .BusinessFaxNumber = ""
        .Email1Address = "mini@mini.com"
        .MobileTelephoneNumber = ""
        .Save 'use .Display if you wish the user to see the contact pop-up
    End With
 
Error_Handler_Exit:
    On Error Resume Next
    Set olcontact = Nothing
    Set olApp = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: AddOlContact" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Sub ExportAccessContactsToOutlook()
   ' Set up DAO Objects.
   Dim oDataBase As Database
   Dim rst As Recordset
   Dim SQL As String
   ' Set up Outlook Objects.
   Dim ol As New Outlook.Application
   Dim olns As Outlook.NameSpace
   Dim cf As Outlook.MAPIFolder
   Dim QRS_Folder As Outlook.MAPIFolder
   Dim c As Outlook.ContactItem
   Dim Prop As Outlook.UserProperty
   On Error GoTo ProcErr
   
'   Set olns = ol.GetNamespace("MAPI")
   Set olns = ol.GetNamespace("MAPI")
'   Set cf = olns.GetDefaultFolder(olFolderContacts)
   Set cf = olns.GetDefaultFolder(olFolderContacts)
   Set QRS_Folder = cf.Folders("QRS_Search")
   
   SQL = "Select * from [Global address list] where last = 'Goddard'"
   Set oDataBase = CurrentDb
   Set rst = oDataBase.OpenRecordset(SQL)
'   QRS_Folder.Items.Add
'    Set myOtherItem = myFolder.Items("Dan Wilson")
'    Set c = myFolder.Items.Add
'    c.CompanyName = myOtherItem.CompanyName
'    c.BusinessAddress = myOtherItem.BusinessAddress
'    c.BusinessTelephoneNumber = myOtherItem.BusinessTelephoneNumber
'    myItem.Display
   
   
   With rst
      .MoveFirst
      ' Loop through the Microsoft Access records.
      Do While Not .EOF
         ' Create a new Contact item.
'         Set c = ol.CreateItem(olContactItem)
         Set c = QRS_Folder.Items.Add
         ' Specify which Outlook form to use.
         ' Change "IPM.Contact" to "IPM.Contact.<formname>" if you've
         ' created a custom Contact form in Outlook.
         c.MessageClass = "IPM.Contact"
         ' Create all built-in Outlook fields.
         If ![Company] <> "" Then c.CompanyName = ![Company]
         c.FirstName = ![first]
         c.LastName = ![last]
         c.Email1DisplayName = ![Display Name]
         c.Account = ![Account]
         c.Email1Address = ![Display Name]
         c.User1 = ![Display Name]
         ' Save and close the contact.
         c.Save
         Debug.Print c.FirstName, c.LastName, c.EntryID
         c.Close olSave
         .MoveNext
      Loop
   End With
   Exit Sub
ProcErr:
   MsgBox Err.Description
End Sub

[LovellDC]

Thank you John, I am green on this so can you please advise where and how I put the code in using Access 2013?

[John_G]

I can do that, but before I do - how do you want to use those addresses?

Do you want to add them to your contact list individually or do you want to create a named contact list in Outlook? In either case they can be used outside of MS Access.

Or, might you want to use MS Access to create and send an Outlook message, getting the required recipient addresses from the database? If this is what best suits your needs, how many recipients might there be on a typical E-Mail?

[LovellDC]

Thanks John, I want to create a contact list and add them in there in Outlook 2013, at the moment there are a few like 15 but as the database grows I may want to add more to the contact list already created.

[LovellDC]

Thanks John, I want to create a contact list and add them in there in Outlook 2013, at the moment there are a few like 15 but as the database grows I may want to add more to the contact list already created.