R
Robin
I have written the following procedure to link a contact
to a task...this procedure is running correctly on one
machine, however, has stopped running correctly on mine.
It pulls contacts however, the contact is not the current
contact that I have open.
Can anyone tell me what might have changed to cause this
to begin acting "weird"?
Public Sub AddLinkedContacttotask()
Dim spoutlook As Outlook.Application
Dim spNameSpace As Outlook.NameSpace
Dim spTasksFolder As Outlook.MAPIFolder
Dim spTasks As Outlook.Items
Dim spTask As Outlook.TaskItem
Dim spContactsFolder As Outlook.MAPIFolder
Dim spcontacts As Outlook.Items
Dim spcontact As Outlook.ContactItem
Dim splinks As Outlook.Links
Dim splink As Outlook.Link
Set spoutlook = CreateObject("outlook.application")
Set spNameSpace = spoutlook.GetNamespace("MAPI")
Set spTasksFolder = spNameSpace.GetDefaultFolder
(olFolderTasks)
Set spTasks = spTasksFolder.Items
Set spTask = spTasks.GetFirst
Set splinks = spTask.Links
'Add new contact
Set spContactsFolder = spNameSpace.GetDefaultFolder
(olFolderContacts)
Set spcontacts = spContactsFolder.Items
Set spcontact = spcontacts.GetFirst
Set splink = splinks.Add(spcontact)
spTask.Save
Debug.Print spTask.ContactNames
Debug.Print spTask.Subject
spTask.Close (olSave)
'loop through links collection
For Each splink In splinks
If splink.Type = olContactItem Then
Set spcontact = splink.Item
If Not spcontact Is Nothing Then
Debug.Print spcontact.FullName
End If
Set spcontact = Nothing
End If
Set splink = Nothing
Next
Done:
Set spcontact = Nothing
Set spcontacts = Nothing
Set spContactsFolder = Nothing
Set splink = Nothing
Set splinks = Nothing
Set spTask = Nothing
Set spTasksFolder = Nothing
Set spNameSpace = Nothing
Set spoutlook = Nothing
Exit Sub
Handler:
Resume Done
End Sub
to a task...this procedure is running correctly on one
machine, however, has stopped running correctly on mine.
It pulls contacts however, the contact is not the current
contact that I have open.
Can anyone tell me what might have changed to cause this
to begin acting "weird"?
Public Sub AddLinkedContacttotask()
Dim spoutlook As Outlook.Application
Dim spNameSpace As Outlook.NameSpace
Dim spTasksFolder As Outlook.MAPIFolder
Dim spTasks As Outlook.Items
Dim spTask As Outlook.TaskItem
Dim spContactsFolder As Outlook.MAPIFolder
Dim spcontacts As Outlook.Items
Dim spcontact As Outlook.ContactItem
Dim splinks As Outlook.Links
Dim splink As Outlook.Link
Set spoutlook = CreateObject("outlook.application")
Set spNameSpace = spoutlook.GetNamespace("MAPI")
Set spTasksFolder = spNameSpace.GetDefaultFolder
(olFolderTasks)
Set spTasks = spTasksFolder.Items
Set spTask = spTasks.GetFirst
Set splinks = spTask.Links
'Add new contact
Set spContactsFolder = spNameSpace.GetDefaultFolder
(olFolderContacts)
Set spcontacts = spContactsFolder.Items
Set spcontact = spcontacts.GetFirst
Set splink = splinks.Add(spcontact)
spTask.Save
Debug.Print spTask.ContactNames
Debug.Print spTask.Subject
spTask.Close (olSave)
'loop through links collection
For Each splink In splinks
If splink.Type = olContactItem Then
Set spcontact = splink.Item
If Not spcontact Is Nothing Then
Debug.Print spcontact.FullName
End If
Set spcontact = Nothing
End If
Set splink = Nothing
Next
Done:
Set spcontact = Nothing
Set spcontacts = Nothing
Set spContactsFolder = Nothing
Set splink = Nothing
Set splinks = Nothing
Set spTask = Nothing
Set spTasksFolder = Nothing
Set spNameSpace = Nothing
Set spoutlook = Nothing
Exit Sub
Handler:
Resume Done
End Sub