VBA Code to permanently delete selected email

[RayB]

Hello,

I just moved to Outlook 2007 when my Windows Live Mail died. After all the fun in moving everything I am looking for some help. I find myself using the shift+delete and return to permanently delete an email. I see lots of suggestions to delete the email and then empty the deleted items folder based on something. I have established that I keep selected deleted emails for some time and then delete them as necessary, however I do not want to clutter the deleted folder with emails that I know when I read them that I do not want to keep. I found that using the laptop built in keyboard also has some issues when I am using the shift+delete buttons. So I am thinking about adding a button that would permanently delete the selected email and thus make things much simpler.

I am new to VBA and thought I might ask here. Also is there is an easier way to accomplish this please suggest it but not if it follows the solution stated above.

Thank you in advance for your help!

 

[Diane Poremsky]

You don't need VBA - use a Quick step instead. Oh, 2007 doesn't have quick Steps. If you don't need the messages deleted immediately, you can use AutoArchive to delete mail in the deleted items and junk folder as they age.

A macro cant delete permanently, it needs to move to deleted folder, then delete.

This appears to work here - if Delete doesn't work, then move to the deleted folder and delete. Its deleting anything moved within the last min - use 1 / 2880 for 30 seconds. Works best if there aren't many messages in the deleted items folder.

Sub PermDelete()

    Dim myOlApp, myNameSpace, Sel, objRecip As Object
    Dim MyItem As Object
    Dim MyItem1 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
    Set DeletedFolder = myNameSpace.GetDefaultFolder(olFolderDeletedItems)

    For i = 1 To Sel.Count
        If Sel.Item(i).Class = olMail Then
            Set MyItem = Sel.Item(i)
            MyItem.Delete ' Move DeletedFolder
        End If
    Next

   Dim obj As Object
 
    For Each obj In DeletedFolder.Items
   
        If DateDiff("N", obj.LastModificationTime, Now) < 1 / 1440 Then
                obj.Delete
            End If
    Next
End Sub

 

[Diane Poremsky]

use 1 / 2880 for 30 seconds.

You can use another number - it seemed to work ok with 30 seconds (could be user error though- i have 2000+ items in the deleted folder and could have missed something.) I know it deletes recent items - you might be limited to deleting everything new in the last min.

If this is a problem, you could add a category and only delete items in that category - this actually might be a better way anyway.

Sub DeleteCategories()

    Dim myOlApp, myNameSpace, Sel, objRecip As Object
    Dim MyItem As Object
    Dim MyItem1 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
    Set DeletedFolder = myNameSpace.GetDefaultFolder(olFolderDeletedItems)

    For i = 1 To Sel.Count
        If Sel.Item(i).Class = olMail Then
            Set MyItem = Sel.Item(i)
            MyItem.Categories = "DeleteMe"
            MyItem.Move DeletedFolder
        End If
    Next

   Dim obj As Object

    For Each obj In DeletedFolder.Items
        If obj.Categories = "DeleteMe" Then
                obj.Delete
            End If
    Next
End Sub

 

[RayB]

Hi Diane,

Thank You for your prompt reply. I have messed around with VBA in Excel but never ventured into Outlook. Very different. I decided as you suggested to add a new folder to avoid dealing with the Deleted Folder and causing issues. I called the new folder Perm Delete (no underscore between the words just a space). I then modified the code you graciously wrote (I don't think I would have ever gotten there) as shown below.

Sub DeleteCategories()

Dim myOlApp, myNameSpace, Sel, objRecip As Object
Dim MyItem As Object
Dim MyItem1 As Outlook.MailItem
Dim PermDeleteFolder As Object
Dim objProperty As Object
Dim SavedEntryId, i

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set Sel = Application.ActiveExplorer.Selection
Set Perm Delete = myNameSpace.GetDefaultFolder(olFolderPerm Delete)

For i = 1 To Sel.Count
If Sel.Item(i).Class = olMail Then
Set MyItem = Sel.Item(i)
MyItem.Categories = "DeleteMe"
MyItem.Move Perm Delete Folder
End If
Next

Dim obj As Object

For Each obj In Perm Delete Folder.Items
If obj.Categories = "DeleteMe" Then
obj.Delete
End If
Next
End Sub

I then opened the VB Editor added a module and pasted the code in. I decided to Step through the code so I could watch what was happening and received this error Run Time Error '429' ActiveX component cannot create object which is associated with this line : Set myOlApp = CreateObject("Outlook.Application")

I have included a screen shot of the VB Editor below:

So how do I fix this error and do you see any other errors in my code?

Thank you again for your help!

Ray

 

[Diane Poremsky]

Set Perm Delete = myNameSpace.GetDefaultFolder(olFolderPerm Delete)

This is not how you reference non-default folders. See Working with VBA and non-default Outlook Folders - you'll use something like this- the Perm Delete folder is a subfolder under Inbox in this example:
Set PermDelete = myNameSpace.GetDefaultFolder(olFolderInbox).Folders.("Perm Delete")

 

[RayB]

Hi again,

I have updated the code based on the reference and here it is:

Sub PermDelete()


Dim muOlApp, myNameSpace, Sel, objRecip As Object
Dim MyItem As Object
Dim MyItem1 As Outlook.MailItem
Dim PermDeleteFolder As Object
Dim objProperty As Object
Dim SavedEntryId, i

Set myOlApp = CreateObject("Outlook.Application")

Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set Sel = Application.ActiveExplorer.Selection
Set PermDeleteFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Folder("Perm Delete")

For i = 1 To Sel.Count
If Sel.Item(i).Class = olMail Then
Set MyItem = Sel.Item(i)
MyItem.Move PermDeleteFolder
End If
Next

Dim obj As Object
For Each obj In PermDeleteFolder.Items

If DateDiff("N", obj.LastModificationTime, Now) < 1 / 1440 Then
obj.Delete
End If
Next
End Sub

Unfortunately when I try to run the macro I get Runtime error #429 Active X component cannot create object on the line
Set myOlApp = CreateObject("Outlook.Application")

I have searched the web and tried many suggestions about code changes but nothing seems to work. There were also suggestions about newer Outlook versions installed over older ones however this is not true for me.

Does anyone have a real solution to this problem?

I am sorry what seemed to be such a simple thing has grown into such a beast....

Thanks in advance for your help!

 

[RayB]

Hi Diane,

I messed around with the code some more and got it to work. Here is where ended up:

Sub PermDelete()

'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

Dim obj As Object

For Each obj In DeletedFolder.Items
If obj.Categories = "DeleteMe" Then
obj.Delete
End If
Next


It works but it takes forever to check each email in the deleted folder. The same is true if I use the date/time modified you suggested. I believe this is because it starts with the oldest email and searches through them until it reaches the most current ones and then deletes them permanently.

Is it possible to turn this search around and start with the most current email, and then only process the 50 most current emails in the Deleted Folder, and if the Category = "DeleteMe" then delete it?

Thank you for your help!

 

[Michael Bauer]

Sort the Items collection descending before the loop starts

deletedfolder.items.sort "[Receivedtime]", true

Then use a For i=1 to 50 loop instead of For Each.

 

[RayB]

Hi,

Here is my attempt at using a For i = 50 loop at the end of the sub to permanently delete the email from the Deleted Folder:

Sub PermDelete()

'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)

DeletedFolder.Items.Sort "[Receivedtime]", True

For i = 1 To 50


If DeletedFolder.Items.Item(i).obj.Categories = "DeleteMeNow" Then
DeletedFolder.Items.Item(i).obj.Delete
End If

Next

End Sub

However, I get a Run Time error 438 Object doesn't support this property or method on the line:


If DeletedFolder.Items.Item(i).obj.Categories = "DeleteMeNow" Then
DeletedFolder.Items.Item(i).obj.Delete

The vba for outlook is very confusing and searching the www has only confused me more. How can this code be fixed? I trust that the Deleted folder sort works since I did not get an error but it looks the same as it was before the sort.

I appreciate your help!

 

[Michael Bauer]

"obj" is a variable you´d used with the For Each loop. It is not a property of Item(i). The loop will be faster if you use variables so that every object has to be referenced as less as possible:

dim items as outlook.items
set items=deletedfolder.items
for i....
set obj=items(i)
if obj.categories...
...

 

[RayB]

Hi,

Thank You for helping me with the items information. After modifying the code to include it the macro still did not delete the item from the Deleted Items folder. I think the sort function worked but the next steps started at the oldest email first. After some digging I learned about counting the items in a folder and then using that count to count down from the highest (that is newest email added) through the previous 50. That worked perfectly.

I have posted the final code below.

Thank you all again!

Sub PermDelete()

'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, Count As Long
Dim items As Outlook.items

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)
Set items = DeletedFolder.items
Count = items.Count

For i = Count To Count - 50 Step -1
Set obj = items(i)
If obj.Categories = "DeleteMeNow" Then
obj.Delete
End If
Next

End Sub