rhysdavies
New member
- Local time
- Today, 09:57
- Joined
- Nov 12, 2007
- Messages
- 3
Hi, this code imports contacts from an accessquery into an exchange public folder for people to use - i import the unique contact ID from the access dbase into the job title field - i want to add code that will check the job title field against the ID in the query and if it is already there i do not want it to create a duplicate contact as it presently does, but i do want it to overwrite the outlook contact with the latest details from the query. any new contacts should just be imported as normal - does anyone know the code required?
thanks.
Private Sub outlook_Click()
Dim rsdbase As Database
Dim rstemp As Recordset
Dim olns As NameSpace
Dim cf As MAPIFolder
Dim c As ContactItem
Dim ol As New outlook.Application
Set olns = ol.GetNamespace("MAPI")
Set cf = olns.GetDefaultFolder(18).Folders.Item("wcc")
Set rsdbase = CurrentDb
Set rstemp = rsdbase.OpenRecordset("qryemailcontacts")
With rstemp
.MoveFirst
Do While Not .EOF
Set c = ol.CreateItem(olContactItem)
c.MessageClass = "IPM.Contact"
Set c = cf.Items.Add
If ![contactID] <> "" Then c.jobtitle = ![contactID]
If ![companyname] <> "" Then c.companyname = ![companyname]
If ![firstname] <> "" Then c.firstname = ![firstname]
If ![surname] <> "" Then c.LastName = ![surname]
If ! <> "" Then c.Email1Address = ![email]
c.save
.MoveNext
Loop
End With
Set ol = Nothing
Set olns = Nothing
MsgBox "All Contacts Successfully Exported to Outlook!"
End Sub
thanks.
Private Sub outlook_Click()
Dim rsdbase As Database
Dim rstemp As Recordset
Dim olns As NameSpace
Dim cf As MAPIFolder
Dim c As ContactItem
Dim ol As New outlook.Application
Set olns = ol.GetNamespace("MAPI")
Set cf = olns.GetDefaultFolder(18).Folders.Item("wcc")
Set rsdbase = CurrentDb
Set rstemp = rsdbase.OpenRecordset("qryemailcontacts")
With rstemp
.MoveFirst
Do While Not .EOF
Set c = ol.CreateItem(olContactItem)
c.MessageClass = "IPM.Contact"
Set c = cf.Items.Add
If ![contactID] <> "" Then c.jobtitle = ![contactID]
If ![companyname] <> "" Then c.companyname = ![companyname]
If ![firstname] <> "" Then c.firstname = ![firstname]
If ![surname] <> "" Then c.LastName = ![surname]
If ! <> "" Then c.Email1Address = ![email]
c.save
.MoveNext
Loop
End With
Set ol = Nothing
Set olns = Nothing
MsgBox "All Contacts Successfully Exported to Outlook!"
End Sub