VBA Script Errors Out When Adding Records to Exchange Folder
Posted on 2007-07-23
I'm trying to synchronize an Exchange 2003 public folder (with contacts in it) with a personal CONTACT folder because the OWA (Outlook Web Access) does not support public folder access. I have settled on using VBA for synch'ing since I can connect to the exchange folders A-OK with MS Access. The problem comes when adding records to the personal contact folder in the VBA script. The first record adds just fine with no error. The second pass/attempt errors out. Here is the code:
Dim cn As ADODB.Connection
Dim rsMine As ADODB.Recordset
Dim rsPub As ADODB.Recordset
Set cn = CurrentProject.AccessConnection
Set rsPub = New ADODB.Recordset
rsPub.ActiveConnection = cn
rsPub.Source = "SELECT * FROM [Public - Contacts]"
rsPub.LockType = adLockOptimistic
rsPub.CursorType = adOpenKeyset
Do While Not rsPub.EOF
Set rsMine = New ADODB.Recordset
rsMine.ActiveConnection = cn
rsMine.Source = "SELECT * FROM Contacts WHERE LCase(Contacts.[User Field 4]) = '" & LCase(rsPub![Email Address] & rsPub!First & rsPub!Last & "") & "';"
rsMine.LockType = adLockOptimistic
rsMine.CursorType = adOpenKeyset
'The error comes on the second pass
If rsMine.EOF Then
rsMine![User Field 4] = rsPub![Email Address] & rsPub!First & rsPub!Last
rsMine!First = rsPub!First
rsMine!Last = rsPub!Last
rsMine!Title = rsPub!Title
rsMine!Company = rsPub!Company
Set rsMine = Nothing
Set rsPub = Nothing
I have tried it with ADODB and DAO...it errors in the same logical place (no difference)
If I exit MS Access and come back in, the script will work 1 time and error out on the 2nd pass.
The exact error is...
Run-time error '-2147467259 (80004005)
Unexpected error has occurred.