linking contacts and appointments using VBA

S

savarin

I am using VBA to create Outlook appointments and contacts from Excel
XP. I can't seem to figure out how to link the appointment to the
contact. Please help.


This is the code I am using to create the contact:

Sub Register_Contact()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Outlook.ContactItem
Dim i As Long

Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.GetDefaultFolder(10)
Set olColItems = olFolder.Items

Application.ScreenUpdating = False

If olColItems.Find("[CompanyName]= " & CStr(Cells(4, 2).Value)) _
Is Nothing Then
Set olItem = olColItems.Add
With olItem
.CompanyName = Cells(3, 2).Value
.Companies = Cells(3, 2).Value
.BusinessAddressStreet = Cells(5, 2).Value
.BusinessAddressPostalCode = Cells(8, 2).Value
.BusinessAddressCity = Cells(6, 2).Value
.BusinessAddressState = Cells(7, 2).Value
.FullName = Cells(4, 2).Value
.Email1Address = Cells(9, 2).Value
.BusinessTelephoneNumber = Cells(10, 2).Value
.BusinessFaxNumber = Cells(11, 2).Value
.Save
End With
End If

Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing

Application.ScreenUpdating = True

MsgBox "The Contacts have successfully been updated!", vbInformation
End Sub

**************************************************

Here is where I create the appointment and try to add the link to the
contact. I am trying to create the link using the Companies item. It is
right after I create the .Companies item that the code seems to be
incorrect. It still creates the appointment. I just can't link them. I
would really appreciate suggestions.


Sub Register_Appointment()
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim itmContact As Outlook.ContactItem
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder

Set olAppItem = olApp.CreateItem(olAppointmentItem)

' creates a new appointment

Set itmContact = olApp.CreateItem(olContactItem)
Set myNameSpace = olApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)

With olAppItem
.Start = Now
.End = Now
.Subject = "No subject"
.Location = ""
.Body = ""
.Companies = ""
.ReminderSet = True
.Companies = ""

' read appointment values from the worksheet

On Error Resume Next
.Start = Cells(12, 2).Value + Cells(13, 2).Value
.End = Cells(12, 2).Value + Cells(14, 2).Value
.Subject = Cells(2, 2).Value
.Location = Cells(16, 2).Value
.Body = Cells(15, 2).Value
.ReminderSet = Cells(20, 2).Value
.Companies = Cells(3, 2).Value
Set itmContact = myFolder.Items.Find(olAppItem.Companies)
olAppItem.Links.Add itmContact
.Categories = Cells(2, 2).Value
On Error GoTo 0
.Save ' saves the new appointment to the default folder
Application.ScreenUpdating = True

MsgBox "This event has been added to your Outlook Calendar",
vbInformation
End With
Set itmContact = Nothing
Set olAppItem = Nothing
Set olApp = Nothing

End Sub
 
K

Ken Slovak - [MVP - Outlook]

You need to use the Links collection to do what you want. Each Link
item is a contact. Save the new item before you attempt to add a link
to it, get the Links collection and use the Add method to add a
resolved contact item reference. See the Object Browser Help on Links
to see some code samples for this. Links can hold approximately 30
contact links per item.




savarin said:
I am using VBA to create Outlook appointments and contacts from Excel
XP. I can't seem to figure out how to link the appointment to the
contact. Please help.


This is the code I am using to create the contact:

Sub Register_Contact()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Outlook.ContactItem
Dim i As Long

Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.GetDefaultFolder(10)
Set olColItems = olFolder.Items

Application.ScreenUpdating = False

If olColItems.Find("[CompanyName]= " & CStr(Cells(4, 2).Value)) _
Is Nothing Then
Set olItem = olColItems.Add
With olItem
CompanyName = Cells(3, 2).Value
Companies = Cells(3, 2).Value
BusinessAddressStreet = Cells(5, 2).Value
BusinessAddressPostalCode = Cells(8, 2).Value
BusinessAddressCity = Cells(6, 2).Value
BusinessAddressState = Cells(7, 2).Value
FullName = Cells(4, 2).Value
Email1Address = Cells(9, 2).Value
BusinessTelephoneNumber = Cells(10, 2).Value
BusinessFaxNumber = Cells(11, 2).Value
Save
End With
End If

Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing

Application.ScreenUpdating = True

MsgBox "The Contacts have successfully been updated!", vbInformation
End Sub

**************************************************

Here is where I create the appointment and try to add the link to the
contact. I am trying to create the link using the Companies item. It is
right after I create the .Companies item that the code seems to be
incorrect. It still creates the appointment. I just can't link them. I
would really appreciate suggestions.


Sub Register_Appointment()
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim itmContact As Outlook.ContactItem
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder

Set olAppItem = olApp.CreateItem(olAppointmentItem)

' creates a new appointment

Set itmContact = olApp.CreateItem(olContactItem)
Set myNameSpace = olApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)

With olAppItem
Start = Now
End = Now
Subject = "No subject"
Location = ""
Body = ""
Companies = ""
ReminderSet = True
Companies = ""

' read appointment values from the worksheet

On Error Resume Next
Start = Cells(12, 2).Value + Cells(13, 2).Value
End = Cells(12, 2).Value + Cells(14, 2).Value
Subject = Cells(2, 2).Value
Location = Cells(16, 2).Value
Body = Cells(15, 2).Value
ReminderSet = Cells(20, 2).Value
Companies = Cells(3, 2).Value
Set itmContact = myFolder.Items.Find(olAppItem.Companies)
olAppItem.Links.Add itmContact
Categories = Cells(2, 2).Value
On Error GoTo 0
Save ' saves the new appointment to the default folder
Application.ScreenUpdating = True

MsgBox "This event has been added to your Outlook Calendar",
vbInformation
End With
Set itmContact = Nothing
Set olAppItem = Nothing
Set olApp = Nothing

End Sub
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Word macro that can call cells out of Excel for a find and replace 0
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0
Exporting from Outlook to Excel Folder Problem 12
linking Outlook appointments and contacts from Excel 1
Outlook VBA Problem 0
Default folder to Public folder when Exporting outlook form data toexcel 1
Loop through pages and insert header image 0
Deleting all outlook contacts. 2

Top