[AccessD] Creating Contacts in Microsoft Outlook

I don't know how you can paste/append because you have to use the
object model of Outlook to do it.

Here are the three functions I use to delete, and rebuild the
contacts in Outlook from a current Access application. It
works with 2000 - 2003.  It has not ben tested or tried with
2007. There is also one to backup the Outlook data file.

Make sure you have the references set to the Outlook object model
and watch out for line wrapping in the code.

Function ExportContact()
     Dim x As Integer
     Dim db As Database
     Dim rs As Recordset
     Dim olkApp As Outlook.Application
     Dim oNameSpace As Outlook.NameSpace
     Dim oFolder As Outlook.MAPIFolder
     Dim oItems As Outlook.Items
     Dim oContact As Outlook.ContactItem
     Dim i As Long
     Dim obj As Object
     Set olApp = CreateObject("outlook.application")
     Set oNameSpace = olApp.GetNamespace("MAPI")
     Set oFolder = oNameSpace.GetDefaultFolder(olFolderContacts)
     x = 1
     DoCmd.Hourglass True
     DoCmd.SetWarnings False
     Debug.Print "Deleting old contacts."
     Call DeleteContacts
     Debug.Print "Delete complete.  Building new list."
     DoCmd.OpenQuery "MTqry_OutlookExport"
     DoCmd.SetWarnings True
     'Dim myFolder As Outlook.Folders
     Set db = CurrentDb()
     Set olkApp = CreateObject("Outlook.Application")
     Set rs = db.OpenRecordset("tmpTbl_OutlookExport")
     rs.MoveFirst
     Debug.Print "Adding contacts"
     Do Until rs.EOF
         Set coniNewContact = olkApp.CreateItem(olContactItem)
         With coniNewContact
             If Not IsNull(rs!CUS_F_NAME) Then .FirstName = rs!CUS_F_NAME
             If Not IsNull(rs!CUS_L_NAME) Then .LastName = rs!CUS_L_NAME
             If Not IsNull(rs!C_TITLENOW) Then .Profession = rs!C_TITLENOW
             If Not IsNull(rs!PCONAME) Then .CompanyName = rs!PCONAME
             If Not IsNull(rs!PNAME) Then .OfficeLocation = rs!PNAME
             If Not IsNull(rs!FullAddress) Then 
.BusinessAddressStreet = rs!FullAddress
             If Not IsNull(rs!city) Then .BusinessAddressCity = rs!city
             If Not IsNull(rs!state) Then .BusinessAddressState = rs!state
             If Not IsNull(rs!zip) Then .BusinessAddressPostalCode = rs!zip
             If Not IsNull(rs!PNAMEID) Then .CustomerID = rs!PNAMEID
             If Not IsNull(rs!SalesRep) Then .Initials = rs!SalesRep
             If Not IsNull(rs!C_HOME_STR) Then .HomeAddress = rs!C_HOME_STR
             If Not IsNull(rs!C_HOME_CTY) Then .HomeAddressCity = rs!C_HOME_CTY
             If Not IsNull(rs!C_HOME_STA) Then .HomeAddressState = 
rs!C_HOME_STA
             If Not IsNull(rs!C_HOME_ZIP) Then .HomeAddressPostalCode 
= rs!C_HOME_ZIP
             If Not IsNull(rs!C_HOMEPHON) Then .HomeTelephoneNumber = 
rs!C_HOMEPHON
             If Not IsNull(rs!C_SPOUSE) Then .Spouse = rs!C_SPOUSE
             If Not IsNull(rs!C_KIDS) Then .Children = rs!C_KIDS
             If Not IsNull(rs!EMAIL) Then .Email1Address = rs!EMAIL
             If Not IsNull(rs!Direct) Then .BusinessTelephoneNumber = rs!Direct
             If Not IsNull(rs![800]) Then .Business2TelephoneNumber = rs![800]
             If Not IsNull(rs!FAX) Then .BusinessFaxNumber = "FAX: " & rs!FAX
             If Not IsNull(rs!Pager) Then .PagerNumber = rs!Pager
             If Not IsNull(rs!Mobile) Then .CarTelephoneNumber = rs!Mobile
             If Not IsNull(rs!Other) Then .OtherTelephoneNumber = rs!Other
             If Not IsNull(rs!Home) Then .HomeTelephoneNumber = rs!Home
             If Not IsNull(rs!Switchboard) Then 
.AssistantTelephoneNumber = rs!Switchboard
             If Not IsNull(rs!Main) Then .CallbackTelephoneNumber = rs!Main
             Debug.Print x
             x = x + 1
             .Save
             rs.MoveNext
             Set coniNewContact = Nothing
         End With
     Loop
     Debug.Print "Finally finished!!!!!!"
     db.Close
     Set db = Nothing
     Set olkApp = Nothing
     DoCmd.Hourglass False
     x = MsgBox("Export completed.", vbOKOnly, "Export")
End Function

Public Sub DeleteContacts()
     Dim olApp As Outlook.Application
     Dim oNameSpace As Outlook.NameSpace
     Dim oFolder As Outlook.MAPIFolder
     Dim oItems As Outlook.Items
     Dim oContact As Outlook.ContactItem
     Dim i As Long
     Dim obj As Object
     Set olApp = CreateObject("outlook.application")
     Set oNameSpace = olApp.GetNamespace("MAPI")
     Set oFolder = oNameSpace.GetDefaultFolder(olFolderContacts)
     On Error Resume Next
     Set oItems = oFolder.Items
     For i = oItems.Count To 1 Step -1
         Set obj = oItems(i)
         If TypeOf obj Is Outlook.ContactItem Then
             obj.Delete
         End If
         oItems.Remove (i)
         'Debug.Print "Record " & i & " of " & oItems.Count '& " 
Company:  " & oContact.CompanyName
     Next
     Set olApp = Nothing
End Sub

Public Sub BackupOutlook()
     ' this should backup the local copy of Outlook
     Dim i As Integer
     With Application.FileSearch
         .NewSearch
         .LookIn = "C:\Documents and Settings"
         .SearchSubFolders = True
         .FileName = "*.pst"
         .MatchTextExactly = False
         .Execute
         For i = 1 To .FoundFiles.Count
             Dim src As String, dest As String
             src = .FoundFiles(i)
             dest = "c:\My Documents\Outlook_BU\Outlook_" & 
DatePart("yyyy", Date) & DatePart("m", Date) & DatePart("d", Date) & 
"_" & i & ".pst"
             FileCopy src, dest
             Debug.Print .FoundFiles(i)
         Next i
     End With
     i = MsgBox("Backup completed.", vbOKOnly, "Backup")
End Sub


At 01:00 PM 3/26/2007, you wrote:
>Date: Mon, 26 Mar 2007 16:16:14 +0100
>From: " Eoin C. Bair?ad " <ebairead at gmail.com>
>Subject: [AccessD] Creating Contacts in Microsoft Outlook
>To: "Access Developers discussion and problem solving"
>         <accessd at databaseadvisors.com>
>Message-ID:
>         <3d2a5ccc0703260816v1d40a406k3b181bb7bb5bc7e8 at mail.gmail.com>
>Content-Type: text/plain; charset=ISO-8859-1; format=flowed
>
>Hi
>
>I have a nice query to create new Outlook Contacts, and another query
>that allows me to Paste/Append these contacts - I've a link to my
>Outlook contacts.
>
>
>Except they're getting appended as Mail Messages rather than Contacts.
>
>Any ideas ?
>
>--
>--
>Eoin C. Bair?ad
>Dublin, Ireland
>?th Cliath, ?ire