Creating Outlook Contacts via Access

[JH]

Folks,

I linked from access to Outlook Contacts happily enough and could see all my
outlook contacts. The when I tried to add a record to the table in Access,
it creates a "Contact" in outlook that behaves like an email! How can I
create fully functional contacts from Access?

John

 

[Guest]

JH:
I don't have an answer for your issue however I have a question -- did you
use the Get External Data- Link Tables for your link? Did it pull in all the
contact fields into your Access table? I ask because after many attempts I
am only getting the company name, phone, fax and mobile phone fields with my
link -- any suggestions?

 

[Eef Houniet]

JH,

Can this procedure help?

Office 2000 uses object library 9.0
Office 2003 uses object library 11.0

I don't know what 'Verwijzingen' should be in English. It is the topmost
line in Tools.

This procedure connects to an existing person in Outlook or adds an new one
if not existing.
Procedure found in: Microsoft Access 2000 Visual Basic for Applications
Fundamenten, Evan Callahan.


Succes,
Eef Houniet.

============================
Private Sub cmdOutlook_Click()
On Error GoTo Fout

'Tools - Verwijzingen (?) - Microsoft Outlook 11.0 Object Library

Dim appOutlook As New Outlook.Application
Dim nsOutlook As NameSpace
Dim mfContactpersonen As MAPIFolder
Dim ciContact As ContactItem

Dim strNaam As String
Dim strZaakAdres As String
Dim strFoonVast As String
Dim strPostCode As String
Dim strPlaats As String
Dim strLand As String
Dim strEmail As String

Let strNaam = Me.Bedrijfsnaam
Let strZaakAdres = Me.Straat & " " & Me.Huisnummer
Let strFoonVast = Me.FoonKengetal & "-" & Me.FoonAbonneenummer
Let strPostCode = Me.PcodeCijfers & " " & Me.PcodeLetters
Let strPlaats = Me.Plaats
Let strLand = "Nederland"
Let strEmail = Me.EmailAdres & "@" & Me.EmailProvider

Set nsOutlook = appOutlook.GetNamespace("MAPI")
Set mfContactpersonen = nsOutlook.GetDefaultFolder(olFolderContacts)

'Work both
' Set ciContact = mfContactpersonen.Items.Find("[FullName] = 'Eef
Houniet'")
Set ciContact = mfContactpersonen.Items.Find("[FullName] = " & strNaam)

If ciContact Is Nothing Then
Set ciContact = mfContactpersonen.Items.Add
ciContact.FullName = strNaam
ciContact.BusinessAddressStreet = strZaakAdres
'ciContact.BusinessAddress = strZaakAdres
ciContact.BusinessTelephoneNumber = strFoonVast
ciContact.BusinessAddressPostalCode = strPostCode
ciContact.BusinessAddressCity = strPlaats
ciContact.BusinessAddressCountry = strLand
ciContact.Email1Address = strEmail
End If

ciContact.Display

Einde:
Exit Sub

Fout:
Application.Echo True
MsgBox Error$
Resume Einde

End Sub
====================