I do this in a .mdb access database (i assume something very similar would
work from an .adp although i haven't tried it). The first time i tried to do
this i looked for help/answers in all the wrong places. Now, i am NOT saying
this is correct or the only way to do it, but it works as far as i could
figure it out. You (obviously) will need to modify it for your own needs but
my comments (i know, limited) might help. You will see from some REM lines
things i thought should have worked and didn't. So, I fell back to the
ubiquitous Server.CreateObject as lot of places (which worked). Hope this
helps (Maybe someone with more skills could tell me what i did wrong in the
first place! but it works anyway - all that really mattered to me at the
time.).
' NOTES
' Requires Reference to Microsoft Outlook Object Library
Private Sub cmdCreateOutlookContact_Click()
' Read person's information using ADO
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
cn.ConnectionString = getConnection
cn.Open
Dim rS1 As ADODB.Recordset
Set rS1 = New ADODB.Recordset
rS1.CursorType = adOpenKeyset
rS1.LockType = adLockOptimistic
Dim strSQL As String
' Get basic person information
strSQL = "SELECT * FROM tblProspecting WHERE apk_prospID = " &
Me.apk_prospID
rS1.Open strSQL, cn
If Not rS1.EOF Then
' Create and Save the contact
' Create Outlook application
Dim oApp
'Set oApp = New Outlook.Application
'Set oApp = Outlook.Application
Set oApp = CreateObject("Outlook.Application")
' Get Namespace and Contacts folder reference
'Dim oNS As Outlook.NameSpace
Dim oNS
'Set oNS = CreateObject("Outlook.NameSpace")
'Set oNS = oApp.NameSpace
Set oNS = oApp.GetNamespace("MAPI")
oNS.Logon "Outlook", "tara", False, True
' Get Contacts folder reference
'Dim oContacts As Outlook.MAPIFolder
Dim oContacts
'Set oContacts = CreateObject("Outlook.MAPIFolder")
'Set oContacts =
oNS.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderContacts)
Set oContacts = oNS.Folders("Public Folders")
Set oContacts = oContacts.Folders("All Public Folders")
'Set oContacts = oContacts.Folders("Test")
Set oContacts = oContacts.Folders("Marketing - Seminars")
Set oContacts = oContacts.Folders("Prospective Associates")
'Dim oProperty As UserProperty
Dim oProperty
'Set oProperty = CreateObject("Outlook.UserProperty")
' Create and Open a new contact.
' in the current folder, using items.add
'Dim oItem As Outlook.ContactItem
Dim oItem
'Set oItem = CreateObject("Outlook.ContactItem")
If Me.prospHasContact = 0 Then
Set oItem = oContacts.Items.Add
Set oProperty = oItem.UserProperties.Find("Database ID")
If TypeName(oProperty) <> "Nothing" Then oProperty.Value =
rS1("apk_prospID")
Me.prospHasContact = True
DoCmd.RunCommand acCmdSaveRecord
Else
' find and open the existing contact
'If IsNull(rs1("prospMiddleName")) Or rs1("prospMiddleName")
= "" Then
' Set oItem = oContacts.Items.Find("[FirstName] = """ &
rs1("prospFirstName") & """ and [LastName] = """ & rs1("prospLastName") &
"""")
'Else
' Set oItem = oContacts.Items.Find("[FirstName] = """ &
rs1("prospFirstName") & """ and [LastName] = """ & rs1("prospLastName") & """
and [MiddleName] = """ & rs1("prospMiddleName") & """")
'End If
Set oItem = oContacts.Items.Find("[Database ID] = " &
rS1("apk_prospID"))
If TypeName(oItem) = "Nothing" Then
Set oItem = oContacts.Items.Add
Set oProperty = oItem.UserProperties.Find("Database ID")
If TypeName(oProperty) <> "Nothing" Then oProperty.Value
= rS1("apk_prospID")
End If
End If
' Setup Contact information...
With oItem
If Not IsNull(rS1("prospNamePrefix")) Then .Title =
rS1("prospNamePrefix")
If Not IsNull(rS1("prospFirstName")) Then .FirstName =
rS1("prospFirstName")
If Not IsNull(rS1("prospMiddleName")) Then .middleName =
rS1("prospMiddleName")
If Not IsNull(rS1("prospLastName")) Then .LastName =
rS1("prospLastName")
If Not IsNull(rS1("prospNameSuffix")) Then .Suffix =
rS1("prospNameSuffix")
If Not IsNull(rS1("prospNickName")) Then .NickName =
rS1("prospNickName")
If Not IsNull(rS1("prospSpFirstName")) Then .Spouse =
rS1("prospSpFirstName")
If Not IsNull(rS1("prospFIN")) Then .GovernmentIDNumber =
rS1("prospFIN")
If Not IsNull(rS1("prospRefBy")) Then .ReferredBy =
rS1("prospRefBy")
If Not IsNull(rS1("prospAnniversary")) Then .Anniversary =
rS1("prospAnniversary")
If Not IsNull(rS1("prospDOB")) Then .Birthday = rS1("prospDOB")
If Not IsNull(rS1("prospCategory")) Then .Categories =
rS1("prospCategory")
If Not IsNull(rS1("prospChildren")) Then .Children =
rS1("prospChildren")
If Not IsNull(rS1("prospHobbies")) Then .Hobby =
rS1("prospHobbies")
If Not IsNull(rS1("prospBusinessName")) Then .CompanyName =
rS1("prospBusinessName")
If Not IsNull(rS1("prospDepartment")) Then .Department =
rS1("prospDepartment")
If Not IsNull(rS1("prospOffice")) Then .OfficeLocation =
rS1("prospOffice")
If Not IsNull(rS1("prospBusinessTitle")) Then .JobTitle =
rS1("prospBusinessTitle")
If Not IsNull(rS1("prospProfession")) Then .Profession =
rS1("prospProfession")
If Not IsNull(rS1("prospManager")) Then .ManagerName =
rS1("prospManager")
If Not IsNull(rS1("prospAssistant")) Then .AssistantName =
rS1("prospAssistant")
If Not IsNull(rS1("prospAddressB1")) Then
..BusinessAddressStreet = rS1("prospAddressB1")
If Not IsNull(rS1("prospAddressB2")) Then
..BusinessAddressPostOfficeBox = rS1("prospAddressB2")
If Not IsNull(rS1("prospCityB")) Then .BusinessAddressCity =
rS1("prospCityB")
If Not IsNull(rS1("prospStateB")) Then .BusinessAddressState
= rS1("prospStateB")
If Not IsNull(rS1("prospZipB")) Then
..BusinessAddressPostalCode = rS1("prospZipB")
If Not IsNull(rS1("prospAddressH1")) Then .HomeAddressStreet
= rS1("prospAddressH1")
If Not IsNull(rS1("prospAddressH2")) Then
..HomeAddressPostOfficeBox = rS1("prospAddressH2")
If Not IsNull(rS1("prospCityH")) Then .HomeAddressCity =
rS1("prospCityH")
If Not IsNull(rS1("prospStateH")) Then .HomeAddressState =
rS1("prospStateH")
If Not IsNull(rS1("prospZipH")) Then .HomeAddressPostalCode =
rS1("prospZipH")
If Not IsNull(rS1("prospAddressO1")) Then .OtherAddressStreet
= rS1("prospAddressO1")
If Not IsNull(rS1("prospAddressO2")) Then
..OtherAddressPostOfficeBox = rS1("prospAddressO2")
If Not IsNull(rS1("prospCityO")) Then .OtherAddressCity =
rS1("prospCityO")
If Not IsNull(rS1("prospStateO")) Then .OtherAddressState =
rS1("prospStateO")
If Not IsNull(rS1("prospZipO")) Then .OtherAddressPostalCode
= rS1("prospZipO")
If Not IsNull(rS1("prospPhAssistant")) Then
..AssistantTelephoneNumber = rS1("prospPhAssistant")
If Not IsNull(rS1("prospPhBusFax")) Then .BusinessFaxNumber =
rS1("prospPhBusFax")
If Not IsNull(rS1("prospPhBus1")) Then
..BusinessTelephoneNumber = rS1("prospPhBus1")
If Not IsNull(rS1("prospPhBus2")) Then
..Business2TelephoneNumber = rS1("prospPhBus2")
If Not IsNull(rS1("prospPhCallback")) Then
..CallbackTelephoneNumber = rS1("prospPhCallback")
If Not IsNull(rS1("prospPhCar")) Then .CarTelephoneNumber =
rS1("prospPhCar")
If Not IsNull(rS1("prospPhCompany")) Then
..CompanyMainTelephoneNumber = rS1("prospPhCompany")
If Not IsNull(rS1("prospPhHome1")) Then .HomeTelephoneNumber
= rS1("prospPhHome1")
If Not IsNull(rS1("prospPhHome2")) Then .Home2TelephoneNumber
= rS1("prospPhHome2")
If Not IsNull(rS1("prospPhHomeFax")) Then .HomeFaxNumber =
rS1("prospPhHomeFax")
If Not IsNull(rS1("prospPhISDN")) Then .ISDNNumber =
rS1("prospPhISDN")
If Not IsNull(rS1("prospPhModile")) Then
..MobileTelephoneNumber = rS1("prospPhModile")
If Not IsNull(rS1("prospPhOtherFax")) Then .OtherFaxNumber =
rS1("prospPhOtherFax")
If Not IsNull(rS1("prospPhOther")) Then .OtherTelephoneNumber
= rS1("prospPhOther")
If Not IsNull(rS1("prospPhPager")) Then .PagerNumber =
rS1("prospPhPager")
If Not IsNull(rS1("prospPhPrimary")) Then
..PrimaryTelephoneNumber = rS1("prospPhPrimary")
If Not IsNull(rS1("prospPhRadio")) Then .RadioTelephoneNumber
= rS1("prospPhRadio")
If Not IsNull(rS1("prospPhTelex")) Then .TelexNumber =
rS1("prospPhTelex")
If Not IsNull(rS1("prospPhTTY")) Then .TTYTDDTelephoneNumber
= rS1("prospPhTTY")
If Not IsNull(rS1("prospEmail1")) Then .Email1Address =
rS1("prospEmail1")
If Not IsNull(rS1("prospEmail2")) Then .Email2Address =
rS1("prospEmail2")
If Not IsNull(rS1("prospEmail3")) Then .Email3Address =
rS1("prospEmail3")
If Not IsNull(rS1("prospIMAddress")) Then .IMAddress =
rS1("prospIMAddress")
If Not IsNull(rS1("prospWebAddress")) Then .WebPage =
rS1("prospWebAddress")
If Not IsNull(rS1("prospUser1")) Then .User1 =
rS1("prospUser1")
If Not IsNull(rS1("prospUser2")) Then .User2 =
rS1("prospUser2")
If Not IsNull(rS1("prospUser3")) Then .User3 =
rS1("prospUser3")
If Not IsNull(rS1("prospUser4")) Then .User4 =
rS1("prospUser4")
Set oProperty = oItem.UserProperties.Find("DoNotCall")
If TypeName(oProperty) <> "Nothing" Then oProperty.Value =
rS1("prospDoNotCall")
'Set oProperty = oItem.UserProperties.Find("LastContactBy")
'If TypeName(oProperty) <> "Nothing" And Not
IsNull(rS1("prospLastContactBy")) Then oProperty.Value =
rS1("prospLastContactBy")
'Set oProperty = oItem.UserProperties.Find("LastContactDate")
'If TypeName(oProperty) <> "Nothing" And Not
IsNull(rS1("prospLastContacted")) Then oProperty.Value =
rS1("prospLastContacted")
'Set oProperty = oItem.UserProperties.Find("LastContactType")
'If TypeName(oProperty) <> "Nothing" Then oProperty.Value =
rS1("prospLastContactMthd")
'Set oProperty = oItem.UserProperties.Find("OmitFromMailings")
'If TypeName(oProperty) <> "Nothing" Then oProperty.Value =
rS1("prospOmitFromMailings")
'Set oProperty = oItem.UserProperties.Find("SeminarDate")
'If TypeName(oProperty) <> "Nothing" And Not
IsNull(rS1("prospSeminarDate")) Then oProperty.Value = rS1("prospSeminarDate")
'Set oProperty = oItem.UserProperties.Find("SeminarLocation")
'If TypeName(oProperty) <> "Nothing" And Not
IsNull(rS1("prospSeminarLocation")) Then oProperty.Value =
rS1("prospSeminarLocation")
Set oProperty = oItem.UserProperties.Find("RepID1")
If TypeName(oProperty) <> "Nothing" Then oProperty.Value =
rS1("repID")
Set oProperty = oItem.UserProperties.Find("LastSynch")
If TypeName(oProperty) <> "Nothing" Then oProperty.Value =
Now()
End With
oItem.Close olSave
' Clean up
Set oItem = Nothing
Set oProperty = Nothing
Set oContacts = Nothing
Set oNS = Nothing
Set oApp = Nothing
End If
rS1.Close
' Clean up
Set rS1 = Nothing
Set cn = Nothing
End Sub
Lots of fun!
