Importing Access data into Outlook 2000 Contacts

[BYarnn]

We are trying to impoting data from an Access 200 table into the contacts in Outlook-why reinvent the wheel when we have the info we need.

The problem: it imports only the data from one (the 2nd) column into contacts and not the other fields

??

 

[Hap007]

Here is some sample code I copied from a post years ago.
Perhaps it might point you in the right direction.

This is pretty technical stuff but I can give you some code that might help you on your way.
the following requires the reference to Microsoft outlook in VBA

Dim objOutlook As Object
Dim objItem As Object
Dim strMailTo As String
Dim strName
Dim strtype
Dim iIndid


'Create a Microsoft Outlook object.
Set objOutlook = CreateObject("Outlook.Application")

'Create and open a new contact form for input.
Set objItem = objOutlook.CreateItem(olMailItem)

strMailTo = DIRECTEMAIL.Text
If strMailTo <> "" Then 'Not IsNull(strMailTo) Or

objItem.To = strMailTo
'cant remember the exact code for message text
'will be somthing like,
'objItem.MessageText = "insert message"

'objItem.Display
objitem.send ' or something similar
End If

'Quit Microsoft Outlook.
Set objOutlook = Nothing



The following code allows me to look into my a shared contacts folder and do stuff with it something in there is sure to help. Basicly one function uses Jet4.0 to add entries and the other uses DAO to read it.


Function addmailaddy(strFirstName, strSecondName, strEmailAddy)
Dim ol As Outlook.Application
Dim olns As Outlook.NameSpace
Dim objAllFolders As MAPIFolder
Dim objPublicFolders As MAPIFolder
Dim objFolder As MAPIFolder
Dim objAllContacts As Outlook.Items
Dim Contact As Outlook.ContactItem
Dim check As Boolean
Dim lngindex As Long
Dim strEmail As String
Dim i As Integer

Set ol = Outlook.Application
Set olns = ol.GetNamespace("MAPI")
Set objAllFolders = olns.Folders("Public Folders")
Set objPublicFolders = objAllFolders.Folders("All Public Folders")
Set objFolder = objPublicFolders.Folders("GHN Contacts")
Set objAllContacts = objFolder.Items
On Error GoTo ErrHandler

strEmail = strEmailAddy


If Not IsNull(strEmailAddy) Then '1
Call checkalreadythere(check, lngindex, strEmailAddy, strFirstName, strSecondName)
If check Then '2
Exit Function
Else '2
If lngindex = 1 Then '3
lngindex = MsgBox("An entry exists for this person with the E-mail:" _
& Chr(13) & strEmailAddy & Chr(13) & "Change the address in the Address book?", vbYesNo)
If lngindex = 6 Then '4
i = 1
Do While lngindex = 6
Set Contact = objAllContacts.Item(i)
If Contact.FIRSTNAME = strFirstName And Contact.LastName = strSecondName Then
'5
lngindex = 0
Contact.Email1Address = strEmail
Contact.Save
End If '5
i = i + 1
Loop
Else '4
Exit Function
End If '4
Else '3
Set Contact = objAllContacts.Add(olContactItem)
Contact.FIRSTNAME = strFirstName
Contact.LastName = strSecondName
Contact.Email1Address = strEmailAddy
Contact.Display (True)
End If '3
End If '2
Else
Exit Function
End If '1

Set ol = Nothing
Set olns = Nothing
Set objAllFolders = Nothing
Set objPublicFolders = Nothing
Set objFolder = Nothing
Set objAllContacts = Nothing
Set Contact = Nothing
ExitHere:
Exit Function
ErrHandler:
Select Case Err.Description
Case "Array index out of bounds."
'should not be able to get here but just in case
Exit Function
End Select

Select Case Err.Number
Case 13
i = i + 1
Resume
Case Else
MsgBox "Err: " & Err.Number & Err.Description & Err.HelpFile, vbCritical
End Select
End Function


Function checkalreadythere(ByRef isthere, ByRef lngfound, ByRef strEmail, ByRef strFirstName, ByRef strSecondName)
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim fld As DAO.Field
Dim i
Dim strConnect As String

strConnect = "Exchange 4.0;MAPILEVEL=\Outlook Address Book\;TABLETYPE=1;user = sconnell"

Set db = OpenDatabase("c:\temp\", False, False, strConnect)
Set rs = db.OpenRecordset("GHN Contacts")
rs.MoveFirst
i = 1

'rs.FindFirst ("First = " & txtfirstname)
Do Until i = -1 Or i = rs.RecordCount
If rs!First = strFirstName Then '3
If rs!Last = strSecondName Then '2
If rs![E-mail address] = strEmail Then '1
isthere = True
i = -2 'next loop will be -1 thus ending loop
Else
strEmail = rs![E-mail address]
lngfound = 1
isthere = False
i = -2 'next loop will be -1 thus ending loop
End If '1
End If '2
End If '3
i = i + 1
rs.MoveNext
Loop
Set db = Nothing
Set rs = Nothing
End Function

Here is a link to the Outlook Info

http://msdn2.microsoft.com/en-us/library/aa155697(office.10).aspx

Hope This Helps,
Hap...

Access Developer

http://www.fcs-software.com/fcsaccessdev.html

Access based Add-on Solutions
Access Consultants forum

http://www.tek-tips.com/threadminder.cfm?pid=1121