Synchronize with Outlook

J

Jonathan Brown

Okay, stupid question. I've got the following code. I sort of ripped it off
a code snippet I found in an Outlook programming book. I've modified it to
apply to my situation. I'd like to run it by all of you out there to see if
I've missed anything. One problem I have is that I can't figure out how to
get the code to run with my OnClick event of my Synchronize button.

My objective is to synchronize my contact management database with outlook.
I believe the code I have should create a new contact folder called "FSR
Tracking Contacts" and then create a new contact item for each record in my
database.

Here's what I've got:


Function CheckNull(s As Variant) As Variant
On Error Resume Next
If IsNull(s) Then
CheckNull = ""
Else
CheckNull = s
End If
End Function

Private Sub Synchronize(objFolder As MAPIFolder)

Dim cnnDB As ADODB.Connection
Dim rstCust As ADODB.Recordset
Dim oContactsFolder As Outlook.MAPIFolder
Dim oContact As Outlook.ContactItem
Dim oContactLinks As Outlook.Links
On Error Resume Next
Me.lblSyncStatus.Caption = "Removing existing items, please wait..."
DoEvents
Set cnnDB = New ADODB.Connection
Set oContactsFolder = objFolder.Folders("FSR Tracking Contacts")
'Delete Existing Items
Do Until oContactsFolder.Items.Count = 0
oContactsFolder.Items.Remove (1)
Loop
On Error GoTo CreateContacts_Error
'Create New Contact Items
Set rstCust = cnnDB.Execute("Select * from qrySynchronize")
Do Until rstCust.EOF
Set oContact = oContactsFolder.Items.Add("Contact")
'CheckNull replaces database Nulls with empty string
oContact.FirstName = CheckNull(rstCust!FirstName)
oContact.LastName = CheckNull(rstCust!LastName)
oContact.BusinessTelephoneNumber = CheckNull(rstCust!WPhone)
oContact.HomeTelephoneNumber = CheckNull(rstCust!HPhone)
oContact.MobileTelephoneNumber = CheckNull(rstCust!CPhone)
oContact.PagerNumber = CheckNull(rstCust!Pager)
oContact.Birthday = CheckNull(rstCust!Bdate)
oContact.BusinessFaxNumber = CheckNull(rstCust!Fax)
oContact.Email1Address = CheckNull(rstCust!Email)
oContact.HomeAddress = CheckNull(rstCust!HAddress)
oContact.HomeAddressCity = CheckNull(rstCust!HCity)
oContact.HomeAddressState = CheckNull(rstCust!HState)
oContact.HomeAddressPostalCode = CheckNull(rstCust!HZip)
oContact.OtherAddress = CheckNull(rstCust!PAddress)
oContact.OtherAddressCity = CheckNull(rstCust!PCity)
oContact.OtherAddressState = CheckNull(rstCust!PState)
oContact.OtherAddressPostalCode = CheckNull(rstCust!PZip)
oContact.FileAs = CheckNull(rstCust!FileAs)
oContact.FullName = CheckNull(rstCust!FullName)
oContact.JobTitle = CheckNull(rstCust!Title)
oContact.Save
rstCust.MoveNext
Me.lblSyncStatus.Caption = "Loading " & CheckNull(rstCust!FullName)
DoEvents
Loop

CreateContacts_Exit:
On Error Resume Next
rstCust.Close
cnnDB.Close
Exit Sub

CreateContacts_Error:
MsgBox "Error#: " & Err.Number & vbCr & Err.Description, vbInformation
Resume CreateContacts_Exit
End Sub
 
J

Jonathan Brown

Considering the fact that no one has responded to this post it tells me that
either I'm way off my marker, or this is actually 10 times more complicated
than I think it should be and no one wants to touch it with a ten foot pole.

Although, I think I still got a chance at making this work. I've made some
changes to the code and I've had some degree of success. Here's what I have
now:

Function CheckNull(s As Variant) As Variant
On Error Resume Next
If IsNull(s) Then
CheckNull = ""
Else
CheckNull = s
End If
End Function

Public Sub cmdSync_Click()

Dim objFolder As MAPIFolder
Dim cnnDB As ADODB.Connection
Dim rstCust As ADODB.Recordset
Dim oContactsFolder As Outlook.MAPIFolder
Dim oNameSpace As NameSpace
Dim oApp As Outlook.Application
Dim oContact As Outlook.ContactItem
Dim syncSuccess As Boolean

DoEvents
Set cnnDB = New ADODB.Connection
Set oApp = CreateObject("Outlook.Application")
Set oNameSpace = oApp.GetNamespace("MAPI")
Set objFolder = oNameSpace.GetDefaultFolder(olFolderContacts)

'Create the FSR Tracking Contacts folder under the default contacts
folder. If the folder already exists, move on.
On Error Resume Next
Me.lblSyncStatus.Caption = "Creating FSR Tracking Contacts Folder"
Set oContactsFolder = objFolder.Folders.Add("FSR Tracking Contacts",
olFolderContacts)

On Error GoTo CreateContacts_Error

'Delete Existing Items
Me.lblSyncStatus.Caption = "Removing existing items, please wait..."
Do Until oContactsFolder.Items.Count = 0
oContactsFolder.Items.Remove (1)
Loop

'Create New Contact Items
Set rstCust = cnnDB.Execute("Select * from qrySynchronize")
Do Until rstCust.EOF
Set oContact = oContactsFolder.Items.Add
'CheckNull replaces database Nulls with empty string
oContact.FirstName = CheckNull(rstCust!FirstName)
oContact.LastName = CheckNull(rstCust!LastName)
oContact.BusinessTelephoneNumber = CheckNull(rstCust!WPhone)
oContact.HomeTelephoneNumber = CheckNull(rstCust!HPhone)
oContact.MobileTelephoneNumber = CheckNull(rstCust!CPhone)
oContact.PagerNumber = CheckNull(rstCust!Pager)
oContact.Birthday = CheckNull(rstCust!Bdate)
oContact.BusinessFaxNumber = CheckNull(rstCust!Fax)
oContact.Email1Address = CheckNull(rstCust!Email)
oContact.HomeAddress = CheckNull(rstCust!HAddress)
oContact.HomeAddressCity = CheckNull(rstCust!HCity)
oContact.HomeAddressState = CheckNull(rstCust!HState)
oContact.HomeAddressPostalCode = CheckNull(rstCust!HZip)
oContact.OtherAddress = CheckNull(rstCust!PAddress)
oContact.OtherAddressCity = CheckNull(rstCust!PCity)
oContact.OtherAddressState = CheckNull(rstCust!PState)
oContact.OtherAddressPostalCode = CheckNull(rstCust!PZip)
oContact.FileAs = CheckNull(rstCust!FileAs)
oContact.FullName = CheckNull(rstCust!FullName)
oContact.JobTitle = CheckNull(rstCust!Title)
oContact.Save
Me.lblSyncStatus.Caption = "Loading " & CheckNull(rstCust!FullName)
rstCust.MoveNext
DoEvents
Loop
syncSuccess = True
Resume CreateContacts_Exit

CreateContacts_Exit:
On Error Resume Next
rstCust.Close
cnnDB.Close
Me.lblSyncStatus.Caption = ""

If syncSuccess = True Then
MsgBox "Synchronization was successful", vbInformation
End If

Exit Sub

CreateContacts_Error:
MsgBox "Error#: " & Err.Number & vbCr & Err.Description, vbInformation
syncSuccess = False
Resume CreateContacts_Exit

End Sub


It will now consistently create a new contact folder called "FSR Tracking
Contacts" under the default contact folder. But it seems to generate an
error anyway. If I don't include the On Error Resume Next it will generate 1
of 2 error messages. First message is "Error#: -2009989111 Unable to create
the folder." This is if the folder already exists. The second message is
"Error#: 0". This is if the folder didn't already exist. But it still
creates the folder. Is there something wrong with my line: Set
oContactsFolder = objFolder.Folders.Add("FSR Tracking Contacts",
olFolderContacts)?

If I leave the On Error Resume Next statement there and try to run it that
way, I get one of two messages that say: "Error#: 3704 Operation is not
allowed with the object is closed" or I get: "Error#: 91 Object variable or
With block variable not set". I don't know what causes each error message in
this scenario.

Anyway, if any of you have any ideas, let me know. I think I need to do
something like: If ContactFolder exists Then move on Else create the folder
and then move on. I hope I haven't confused any of you further with this new
post.

Thanks,
Jonathan
 
J

Jonathan Brown

Okay everyone, or anyone who's reading this, I've made some more progress. I
found out that my main issue was that my recordset was not defined properly.
Here's the code that I have now:

Function CheckNull(s As Variant) As Variant
On Error Resume Next
If IsNull(s) Then
CheckNull = ""
Else
CheckNull = s
End If
End Function

Public Sub cmdSync_Click()

Dim objFolder As Outlook.MAPIFolder
Dim rstCust As DAO.Recordset
Dim oContactsFolder As Outlook.MAPIFolder
Dim oNameSpace As NameSpace
Dim oApp As Outlook.Application
Dim oContact As Outlook.ContactItem
Dim syncSuccess As Boolean

DoEvents
Set rstCust = CurrentDb.OpenRecordset("Select * from qrySynchronize")
Set oApp = CreateObject("Outlook.Application")
Set oNameSpace = oApp.GetNamespace("MAPI")
Set objFolder = oNameSpace.GetDefaultFolder(olFolderContacts)

'Create the FSR Tracking Contacts folder under the default contacts
folder. If the folder already exists, move on.
On Error Resume Next
Me.lblSyncStatus.Caption = "Creating FSR Tracking Contacts Folder"
Set oContactsFolder = objFolder.Folders.Add("FSR Tracking Contacts",
olFolderContacts)

On Error GoTo CreateContacts_Error

'Delete Existing Items
Me.lblSyncStatus.Caption = "Removing existing items, please wait..."
Do Until oContactsFolder.Items.Count = 0
oContactsFolder.Items.Remove (1)
Loop

'Create New Contact Items
Do Until rstCust.EOF
Set oContact = oContactsFolder.Items.Add(olContactItem)
'CheckNull replaces database Nulls with empty string
oContact.FirstName = CheckNull(rstCust!FirstName)
oContact.LastName = CheckNull(rstCust!LastName)
oContact.BusinessTelephoneNumber = CheckNull(rstCust!WPhone)
oContact.HomeTelephoneNumber = CheckNull(rstCust!HPhone)
oContact.MobileTelephoneNumber = CheckNull(rstCust!CPhone)
oContact.PagerNumber = CheckNull(rstCust!Pager)
oContact.Birthday = CheckNull(rstCust!Bdate)
oContact.BusinessFaxNumber = CheckNull(rstCust!Fax)
oContact.Email1Address = CheckNull(rstCust!Email)
oContact.HomeAddress = CheckNull(rstCust!HAddress)
oContact.HomeAddressCity = CheckNull(rstCust!HCity)
oContact.HomeAddressState = CheckNull(rstCust!HState)
oContact.HomeAddressPostalCode = CheckNull(rstCust!HZip)
oContact.OtherAddress = CheckNull(rstCust!PAddress)
oContact.OtherAddressCity = CheckNull(rstCust!PCity)
oContact.OtherAddressState = CheckNull(rstCust!PState)
oContact.OtherAddressPostalCode = CheckNull(rstCust!PZip)
oContact.FileAs = CheckNull(rstCust!FileAs)
oContact.FullName = CheckNull(rstCust!FullName)
oContact.JobTitle = CheckNull(rstCust!Title)
oContact.Save
Me.lblSyncStatus.Caption = "Loading " & CheckNull(rstCust!FullName)
rstCust.MoveNext
DoEvents
Loop
syncSuccess = True
Resume CreateContacts_Exit

CreateContacts_Exit:
On Error Resume Next
rstCust.Close
Me.lblSyncStatus.Caption = ""

If syncSuccess = True Then
MsgBox "Synchronization was successful", vbInformation
End If

Exit Sub

CreateContacts_Error:
MsgBox "Error#: " & Err.Number & vbCr & Err.Description, vbInformation
syncSuccess = False
Resume CreateContacts_Exit

End Sub

Now my problem is that I'm getting a "Error#: 13 Type Mismatch" message.
Does anyone happen to see anything inside my Do Until...Loop that possibly
might not match the proper data type?
 
D

Dan Artuso

Hi,
Find out which line is causing the error. Step through the code.
Does this:
Do Until oContactsFolder.Items.Count = 0
oContactsFolder.Items.Remove (1)
Loop

actually work? I've never seen that syntax before.
 
J

Jonathan Brown

Hi Dan,

Thanks for your reply. I finally figured it out today. Here's the working
code that I'm using if you're interested:

Function CheckNull(s As Variant) As Variant
On Error Resume Next
If IsNull(s) Then
CheckNull = ""
Else
CheckNull = s
End If
End Function

Public Sub cmdSync_Click()

Dim objFolder As Outlook.MAPIFolder
Dim rstCust As DAO.Recordset
Dim cnnDB As DAO.Database
Dim oContactsFolder As Outlook.MAPIFolder
Dim oNameSpace As NameSpace
Dim oApp As Outlook.Application
Dim oContact As Outlook.ContactItem
Dim syncSuccess As Boolean
Dim strFileAs As String
Dim strFullName As String
Dim intRecordCount As Integer

DoCmd.Hourglass True

Set cnnDB = CurrentDb()
Set rstCust = cnnDB.OpenRecordset("Select * From qrySynchronize")
Set oApp = CreateObject("Outlook.Application")
Set oNameSpace = oApp.GetNamespace("MAPI")
Set objFolder = oNameSpace.GetDefaultFolder(olFolderContacts)

intRecordCount = 0

'Create the FSR Tracking Contacts folder under the default contacts
folder. If the folder already exists, move on.
On Error Resume Next
Set oContactsFolder = objFolder.Folders.Add("FSR Tracking Contacts",
olFolderContacts)

On Error GoTo CreateContacts_Error

'Delete Existing Items
Set oContactsFolder = objFolder.Folders("FSR Tracking Contacts")

If oContactsFolder.Items.Count > 0 Then
Do Until oContactsFolder.Items.Count = 0
oContactsFolder.Items.Remove (1)
Loop
End If

'Create New Contact Items
With rstCust
If Not .BOF Or .EOF Then
Do Until .EOF
strFileAs = rstCust!LastName & ", " & rstCust!FirstName
strFullName = rstCust!FirstName & " " & rstCust!LastName
Set oContact = oContactsFolder.Items.Add(olContactItem)
'CheckNull replaces database Nulls with empty string
oContact.FirstName = CheckNull(rstCust!FirstName)
oContact.LastName = CheckNull(rstCust!LastName)
oContact.BusinessTelephoneNumber = CheckNull(rstCust!WPhone)
oContact.HomeTelephoneNumber = CheckNull(rstCust!HPhone)
oContact.MobileTelephoneNumber = CheckNull(rstCust!CPhone)
oContact.PagerNumber = CheckNull(rstCust!Pager)
oContact.BusinessFaxNumber = CheckNull(rstCust!Fax)
oContact.Email1Address = CheckNull(rstCust!Email)
oContact.HomeAddress = CheckNull(rstCust!HAddress)
oContact.HomeAddressCity = CheckNull(rstCust!HCity)
oContact.HomeAddressState = CheckNull(rstCust!HState)
oContact.HomeAddressPostalCode = CheckNull(rstCust!HZip)
oContact.OtherAddress = CheckNull(rstCust!PAddress)
oContact.OtherAddressCity = CheckNull(rstCust!PCity)
oContact.OtherAddressState = CheckNull(rstCust!PState)
oContact.OtherAddressPostalCode = CheckNull(rstCust!PZip)
oContact.FileAs = CheckNull(strFileAs)
oContact.FullName = CheckNull(strFullName)
oContact.JobTitle = CheckNull(rstCust!Title)
oContact.Categories = "FSR Tracking Contacts"
oContact.Save
intRecordCount = intRecordCount + 1
.MoveNext
Loop
.Close
End If
End With

DoCmd.Hourglass False
syncSuccess = True

CreateContacts_Exit:
If syncSuccess = True Then
MsgBox "Synchronization was successful" & vbCr & intRecordCount & "
Records Loaded", vbInformation
End If

Exit Sub

CreateContacts_Error:
MsgBox "Error#: " & Err.Number & vbCr & Err.Description, vbInformation
syncSuccess = False
GoTo CreateContacts_Exit

End Sub
 

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

Synchronize with Access DB 2
exporting contacts as vcards with Visual Basic. 1
Excel VB to create and send an outlook appointment with html code 1
Getting Outlook contacts to list in Excel 2003 1
Getting Outlook contacts to list in Excel 2003 1
Working with Outlook Contacts from Access 13
Problem with report passing filter 1
Outlook Reminder Problem after Re-scheduling Appointment using Access VBA 0

Top