VBA code to directly purge single or multiple items from any folder

[JimDandy]

I am looking for code that would allow for the complete removal of a single or multiple selected items that I can assign to a button on the ribbon. I have found code from 2010 that sorta works but fails often enough that it's not overly functional. The code moves items to the deleted folder then deletes the item from there to perform the purge. The trouble seems to be that if there's non-mail items in the folder, among some other mail items that I cannot determine, the code errors out with a run-time error '13'; Type mismatch during the second For-loop at the "Next" statement. The code seems to loop through every item in the deleted folder to find the one to permanently delete. If the trash folder is empty, then it works fine, but I use the deleted folder to hold certain items until I'm sure the issue has passed before I purge them with the second delete or the Shift-Delete process. It's a Godaddy IMAP email account if that helps.

Is there someone that can maybe look at this code and determine how to trap and work around the various mail types that are causing it to fail? The original post is at outlookcode.com /codedetail.aspx?id=502 (I cannot yet post a link)



Sub DeleteDelete()
'Usage: Permanently delete mail items
'How to use: select the mail items; execute this macro
Dim myOlApp, myNameSpace, Sel, objRecip As Object
Dim MyItem As Outlook.MailItem
Dim DeletedFolder As Object
Dim objProperty As Object

Dim SavedEntryId, I

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")

Set Sel = Application.ActiveExplorer.Selection

For I = 1 To Sel.Count
If Sel.Item(I).Class = olMail Then
Set MyItem = Sel.Item(I)
MyItem.UserProperties.Add "DeleteMeNow", olText
MyItem.Save
MyItem.Delete ' Places message in the Deleted Items folder
End If
Next

Set DeletedFolder = myNameSpace.GetDefaultFolder(olFolderDeletedItems)
For Each MyItem In DeletedFolder.Items
Set objProperty = MyItem.UserProperties.Find("DeleteMeNow")
If TypeName(objProperty) <> "Nothing" Then
MyItem.Delete
End If
Next

End Sub

[gmayor]

If you are running the code from Outlook, yoiu don't need to create a new Outlook Application. Use the one you are running the macro from.
Personally I would use a category rather than a property to hold the deletion flag, but the real offender in the macro is
Dim MyItem As Outlook.MailItemChange that to
Dim MyItem as ObjectThus with a category
Sub DeleteDelete()
'Usage: Permanently delete mail items
'How to use: select the mail items; execute this macro
Dim myOlApp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim Sel As Selection
Dim MyItem As Object
Dim DeletedFolder As Outlook.Folder
Dim i As Integer

Set myOlApp = Outlook.Application
Set myNameSpace = myOlApp.GetNamespace("MAPI")

Set Sel = Application.ActiveExplorer.Selection

For i = Sel.Count To 1 Step -1 'Process in reverse order so as not to screw up the count
Set MyItem = Sel(i)
MyItem.categories = "DeleteMeNow"
MyItem.Save
MyItem.Delete ' Places message in the Deleted Items folder
Next

Set DeletedFolder = myNameSpace.GetDefaultFolder(olFolderDeletedItems)
For Each MyItem In DeletedFolder.Items
If MyItem.categories = "DeleteMeNow" Then MyItem.Delete
Next
End SubNote that the code will baulk if used to attempt to remove recurring appointments.

[JimDandy]

The change seems to have been the key, many thanks!