Loop through folders and send to pst file

I'm having trouble with the following code.

I'm trying to loop through the parent folder of the default inbox and move all non default folders to an archive.

The correctly creates the archive and loops through until it hits a folder that should be moved but errors with #424(Object Required) on the indicated line.

Any thoughts?

Private Sub Command0_Click()
Dim oApplication As Outlook.Application
Dim oMapi As NameSpace
Dim oSentItemsFolder As MAPIFolder
Dim oDeletedItemsFolder As MAPIFolder
Dim oOtherFolder As MAPIFolder
Dim oOtherSubFolder As MAPIFolder
Dim oAAAArchive As MAPIFolder
Dim oSentArchive As MAPIFolder
Dim oDeleteArchive As MAPIFolder
Dim oInboxParentFolder As MAPIFolder
Dim oItems As Object
Dim ocurItem As MailItem
Dim oCheck As Double

DoCmd.SetWarnings False
DoCmd.Hourglass True

Set oApplication = New Outlook.Application
Set oMapi = oApplication.GetNamespace("MAPI")
Set oSentItemsFolder = oMapi.GetDefaultFolder(olFolderSentMail)
Set oDeletedItemsFolder = oMapi.GetDefaultFolder(olFolderDeletedItems)

For i = 1 To oMapi.Folders.Count
    If oMapi.Folders.Item(i).Name = "Personal Folders" Then
    oMapi.Folders.Item(i).Name = "Existing Personal Folders"
    End If
Next

oMapi.AddStore ("C:\AAA Archive.pst")
oMapi.Folders.Item("Personal Folders").Name = "AAA Archive"
Set oAAAArchive = oMapi.Folders.Item("AAA Archive")

'oMapi.AddStore ("C:\Sent Items Archive.pst")
'Set oSentArchive = oMapi.Folders.Item("Personal Folders")
'oSentArchive.Name = "Sent Items Archive"
'oSentItemsFolder.CopyTo oSentArchive

'oMapi.AddStore ("C:\Deleted Items Archive.pst")
'Set oDeleteArchive = oMapi.Folders.Item("Personal Folders")
'oDeleteArchive.Name = "Deleted Items Archive"
'oDeletedItemsFolder.CopyTo oDeleteArchive.Folders("Deleted Items")

Set oInboxParentFolder = oMapi.GetDefaultFolder(olFolderInbox).Parent

For Each oItems In oInboxParentFolder.Folders
   
    Select Case oItems.Name
       
        Case oMapi.GetDefaultFolder(olFolderCalendar).Name
        oCheck = 0
       
        Case oMapi.GetDefaultFolder(olFolderContacts).Name
        oCheck = 0
       
        Case oMapi.GetDefaultFolder(olFolderDeletedItems).Name
        oCheck = 0
       
        Case oMapi.GetDefaultFolder(olFolderDrafts).Name
        oCheck = 0
       
        Case oMapi.GetDefaultFolder(olFolderInbox).Name
        oCheck = 0
       
        Case oMapi.GetDefaultFolder(olFolderJournal).Name
        oCheck = 0
       
        Case oMapi.GetDefaultFolder(olFolderNotes).Name
        oCheck = 0
       
        Case oMapi.GetDefaultFolder(olFolderOutbox).Name
        oCheck = 0
       
        Case oMapi.GetDefaultFolder(olFolderSentMail).Name
        oCheck = 0
       
        Case oMapi.GetDefaultFolder(olFolderTasks).Name
        oCheck = 0
       
        Case "Synchronization Failures"
        oCheck = 0
       
        Case Else
        oCheck = 1
               
    End Select
   
    If oCheck = 1 Then
    Set oOtherFolder = oItems
    oOtherFolder.CopyTo (oAAAArchive) ' ERRORS OUT HERE BUT THE oOtherFolder variable has the correct name value
    Set oOtherFolder = Nothing
    End If
   
Next

'Do While oSentItemsFolder.Items.Count > 0
'    oSentItemsFolder.Items.Item(1).Delete
'Loop

'Do While oDeletedItemsFolder.Items.Count > 0
'    oDeletedItemsFolder.Items.Item(1).Delete
'Loop

For i = 1 To oMapi.Folders.Count
    If oMapi.Folders.Item(i).Name = "Existing Personal Folders" Then
    oMapi.Folders.Item(i).Name = "Personal Folders"
    End If
Next

Set oDeletedItemsFolder = Nothing
Set oSentItemsFolder = Nothing
Set oAAAArchive = Nothing
Set oSentArchive = Nothing
Set oDeleteArchive = Nothing
Set oOtherFolder = Nothing
Set oInboxParentFolder = Nothing
Set myitems = Nothing
Set oMapi = Nothing
oApplication.Quit
Set oApplication = Nothing

DoCmd.SetWarnings True
DoCmd.Hourglass False
MsgBox "Complete", vbOKOnly, "Outlook Archive Tool"
End Sub

Thanks,

perkc

Start Free Trial