VBA script to move deleted contacts to new folder not working

Question

A simple sample script to create a new email works fine.

But this script doesn't

Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.NameSpace
    Dim olContactsFolder As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olContactsFolder = olNamespace.GetDefaultFolder(olFolderContacts)

    ' Hook the BeforeItemMove event of the Contacts folder
    Set g_olContactsFolder = olContactsFolder ' g_olContactsFolder should be a global variable
End Sub

Private Sub g_olContactsFolder_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)
    ' Check if the item is being moved to the Deleted Items folder
    If MoveTo.Name = "Deleted Items" Then
        Dim olDestinationFolder As Outlook.MAPIFolder
        Dim olNamespace As Outlook.NameSpace

        Set olNamespace = Outlook.Application.GetNamespace("MAPI")

        ' Specify your custom folder for deleted contacts
        ' You might need to adjust the path based on your folder structure
        On Error Resume Next
        Set olDestinationFolder = olNamespace.Folders("Personal Folders").Folders("Deleted Contacts Archive") ' Example path
        On Error GoTo 0

        If olDestinationFolder Is Nothing Then
            ' Create the folder if it doesn't exist
            Set olDestinationFolder = olNamespace.Folders("Personal Folders").Folders.Add("Deleted Contacts Archive")
        End If

        ' Move the contact item to the custom folder
        Item.Move olDestinationFolder

        ' Cancel the default move to Deleted Items
        Cancel = True
    End If
End Sub

When I open Outlook, I get a warning that there is a script, and I OK it. When I delete a Contact, it simply goes into the deleted items folder. (I delete hundreds of emails a day, and never notice if a Contact is in the list)

I added dev mode. I saved the script. I exited and restarted Outlook. I get a warning that there is a script I OK it I delete a Contact. It goes into the Deleted items folder, not the new one.

What am I missing?

Answer 1

This works for me.

I created a folder "ContactsArchive" inside my Contacts folder as the destination for deleted contacts (I had problems moving the contacts to a regular folder).

All code is in the ThisOutlookSession module.

Option Explicit

Dim WithEvents g_olContactsFolder As Folder

Private Sub Application_Startup()
    Set g_olContactsFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
End Sub

Private Sub g_olContactsFolder_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)
    Static Skip As Boolean
    
    If Skip Then Exit Sub '## exit if this was triggered by the code below
    
    If MoveTo.Name = "Deleted Items" Then
        Skip = True       '## set flag to ignore the move we're about to do...
        Item.Move g_olContactsFolder.Folders("ContactsArchive")
        Cancel = True
    End If
    Skip = False '## unset the flag
End Sub

'Return the root folder for the default store
Function DefaultRootFolder() As Folder
    Set DefaultRootFolder = Application.GetNamespace("MAPI").DefaultStore.GetRootFolder
End Function

Answer 2

Verify the "Deleted Contacts Archive" folder's DefaultItemType is olContactItem.

Option Explicit

Dim WithEvents g_olContactsFolder As Folder

Private Sub Application_Startup()
    Set g_olContactsFolder = Session.GetDefaultFolder(olFolderContacts)
End Sub


Private Sub g_olContactsFolder_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As Folder, Cancel As Boolean)

    ' Check if the item is being moved to the Deleted Items folder
    If MoveTo.NAME = "Deleted Items" Then
    
        Dim olDestinationPersonalFolder As Folder
        Dim olDestinationArchiveFolder As Folder
        
        ' Specify your custom folder for deleted contacts
        ' You might need to adjust the path based on your folder structure
        On Error Resume Next
        ' "Personal Folders" at mailbox level
        Set olDestinationFolder = Session.Folders("Personal Folders")
        On Error GoTo 0
        
        If olDestinationPersonalFolder Is Nothing Then
            MsgBox "Personal Folders not found."
            Cancel = True
            Exit Sub
        End If
                
        On Error Resume Next
        Set olDestinationArchiveFolder = olDestinationPersonalFolder.Folders("Deleted Contacts Archive")
        On Error GoTo 0
        
        If olDestinationArchiveFolder Is Nothing Then
            ' Create the folder if it doesn't exist
            ' Specify default type as contact item if different from parent folder
            Set olDestinationArchiveFolder = olDestinationPersonalFolder.Folders.Add("Deleted Contacts Archive", olFolderContacts)
        Else
            If olDestinationArchiveFolder.DefaultItemType <> olContactItem Then
                ' Created manually without specifying DefaultItemType
                MsgBox "Deleted Contacts Archive found: DefaultItemType is not Contact Item."
                Cancel = True
                Exit Sub
            End If
        End If

        ' Move the contact item to the custom folder
        Item.Move olDestinationArchiveFolder

        ' Cancel the default move to Deleted Items
        Cancel = True
    End If
End Sub

Sub test()

    Dim currItem As Object
    Set currItem = ActiveExplorer.selection(1)
    
    Dim destFolder As Folder
    Set destFolder = Session.GetDefaultFolder(olFolderDeletedItems)
    
    If TypeOf currItem Is ContactItem Then
        g_olContactsFolder_BeforeItemMove currItem, destFolder, False
    End If
    
End Sub