Error copying a public Contact folder within Outlook 2000 SR1
Function CreateLocalRosterAddressFolder()
Dim lFolder As Outlook.MAPIFolder
Dim ViewFolder As Outlook.MAPIFolder
Dim perFolder As Outlook.MAPIFolder
Dim pFolder As Outlook.MAPIFolder
Dim lRoster As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim AllItems As Outlook.Items
Dim URItems As Outlook.Items
Dim Response As VbMsgBoxResult
Dim ALists As Outlook.AddressLists
Dim AList As Outlook.AddressList
Dim myItem As Variant
On Error Resume Next
For Each lFolder In ThisOutlookSession.Session.Folders
If InStr(1, lFolder.Name, "Personal Folders", vbTextCompare) <> 0
Then
Set perFolder = ThisOutlookSession.Session.Folders("Personal
Folders")
If perFolder.Name <> "Personal Folders" Then
perFolder.Name = "Personal Folders"
End If
End If
Next
If perFolder Is Nothing Then
GoTo Lastline
End If
Set lRoster = perFolder.Folders("Contacts").Folders("Roster Addresses
Local")
On Error GoTo err_Create
If lRoster Is Nothing Then
Response = MsgBox("Outlook Enhancements must now create a local copy
of Roster Addresses.", vbInformation, "Outlook Enhancement Configuration")
If Response <> vbOK Then
GoTo Lastline
End If
'MsgBox "Select the correct Public Roster Addresses Listing.",
vbInformation, "Select List"
Set pFolder = ThisOutlookSession.Session.Folders("Public
Folders").Folders("All Public Folders").Folders("Roster Addresses")
If pFolder Is Nothing Then
GoTo Lastline
End If
With frmSynchronize
.Caption = "Please wait.."
.lblStatus.Caption = "Creating Local Roster Addresses..":
DoEvents
.progStatus.Visible = False
.Show
End With
frmSynchronize.lblStatus.Caption = "Copying folder...": DoEvents
'Copy Roster addresses to local contacts folder
' *** Ken...This is the actual method that errors when it completes copy
process. Same function is perform if you manually drag/drop/copy folder,
with same error.
Set lFolder = pFolder.CopyTo(perFolder.Folders("Contacts"))
'Mark items as read in this folder
Set AllItems = lFolder.Items
Set URItems = AllItems.Restrict("[UnRead] = True")
If URItems.Count >= 1 Then
Response = MsgBox("Would you like to mark all contact items as
read?", vbYesNo, "Mark Items as Read")
If Response <> vbYes Then
GoTo SkipMarkAsRead
End If
End If
frmSynchronize.lblStatus.Caption = "Marking Items as Read...":
DoEvents
MarkAsUnread:
Set URItems = AllItems.Restrict("[UnRead] = True")
frmSynchronize.lblStatus.Caption = "Marking Items as Read (" &
URItems.Count & ")"
If URItems.Count > 0 Then
Set myItem = URItems.GetFirst
If Not myItem Is Nothing Then
myItem.UnRead = False
DoEvents
End If
GoTo MarkAsUnread
End If
SkipMarkAsRead:
frmSynchronize.lblStatus.Caption = "Renaming Folder..": DoEvents
lFolder.Name = "Roster Addresses Local"
frmSynchronize.lblStatus.Caption = "Configuring Contacts Web
View..": DoEvents
Set ViewFolder = ThisOutlookSession.Session.Folders("Personal
Folders").Folders("Contacts")
'Set Web View for local contacts folder
ViewFolder.WebViewOn = True
ViewFolder.WebViewURL = "C:\ECAR Program
files\Outlook\HTML\Contacts.htm"
Else
Set lFolder = perFolder.Folders("Contacts").Folders("Roster
Addresses Local")
Set ViewFolder = perFolder.Folders("Contacts")
'Set Web View for local contacts folder
ViewFolder.WebViewOn = True
ViewFolder.WebViewURL = "file:C:\ECAR Program
files\Outlook\HTML\Contacts.htm"
End If
Lastline:
On Error Resume Next
Set lFolder = Nothing
Set pFolder = Nothing
Set myItems = Nothing
Set perFolder = Nothing
Set ViewFolder = Nothing
Set ALists = Nothing
Set AList = Nothing
Unload frmSynchronize
Exit Function
err_Create:
MsgBox Err.Description, vbCritical, "Error " & Err.Number
Resume Lastline
End Function
