' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Private Sub myOlExp_BeforeFolderSwitch(ByVal NewFolder As Object, Cancel As Boolean)
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlFolder As Outlook.Folder
            
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlFolder = myOlExp.CurrentFolder
    CleanseFolder myOlFolder
End Sub

Public Function SubFolderExists(myOlFolder As Outlook.Folder, ByVal strName As String)
    On Error GoTo Err_SubFolderExists
    
    Dim testFolder As Outlook.Folder
    Set testFolder = myOlFolder.Folders(strName)
    
    SubFolderExists = True
    Exit Function
Err_SubFolderExists:
    SubFolderExists = False
    Exit Function
End Function

Public Sub CleanseFolder(myOlFolder As Outlook.Folder)
    On Error GoTo Err_CleanseFolder
    
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlNameSpace As Outlook.NameSpace
    Dim rootOlFolder As Outlook.Folder
    Dim trashOlFolder As Outlook.Folder
    Dim folderType As Variant
    Dim intCurrentMessage As Long
    Dim currentMailItem As Outlook.MailItem
    Dim oItems As Outlook.Items
    Dim Filter As String
                            
    ' verify the selected folder is a mail folder
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlNameSpace = myOlApp.GetNamespace("MAPI")
    folderType = myOlFolder.DefaultItemType
    If TypeName(myOlExp) = "Nothing" Or folderType <> 0 Then
        Exit Sub
    End If
    
    ' get the root folder
    Set rootOlFolder = myOlFolder
    Do Until rootOlFolder.Parent = myOlNameSpace
        Set rootOlFolder = rootOlFolder.Parent
    Loop
    
    ' if there is no trash folder, bail
    If Not SubFolderExists(rootOlFolder, "Trash") Then
        Exit Sub
    End If
    
    ' get the trash folder
    Set trashOlFolder = rootOlFolder.Folders("Trash")
    
    ' if we're in the trash folder already, bail
    If myOlFolder = trashOlFolder Then
        Exit Sub
    End If

    ' DASL filter to test for IMAP deleted status
    Filter = "@SQL=" & Chr(34) & "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/85700003" & Chr(34) & " = 1"
    Set oItems = myOlFolder.Items.Restrict(Filter)
    For intCurrentMessage = 1 To oItems.count
        Set currentMailItem = oItems.Item(intCurrentMessage)
               
        ' move deleted items to trash folder
        currentMailItem.Move trashOlFolder
    Next
    
    ' purge the imap folder
    myOlExp.CommandBars("Menu Bar").Controls("Edit").Controls("Purge").Controls("Purge Marked Items in " & Chr$(34) & myOlFolder.Name & Chr$(34)).Execute

Err_CleanseFolder:
End Sub