Delete Outlook Emails from MS Access

shieldsco
shieldsco used Ask the Experts™
on
I'm using the below code to delete outlook items wit xlsx attachments. The issue encountered is that only some of the emails are deleted. Any thoughts

On Error GoTo SaveAttachmentsToFolder_err

    Dim ns As NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim Item As Object
    Dim Atmt As Outlook.Attachment
    Dim FileName As String
    
    Dim SubFolder As MAPIFolder
    
    
    
    
    Set ns = GetNamespace("MAPI")

    Set recip = ns.CreateRecipient("OMHA.HQ.MI.REPORTS")
   
    Set Inbox = ns.GetSharedDefaultFolder(recip, olFolderInbox)
    
    Set SubFolder = Inbox.Folders("MATS")


    If SubFolder.Items.Count = 0 Then
    
        MsgBox "There are no messages with attachments in the MATS folder.", vbInformation, _
                "Nothing Found"
        Exit Sub
    End If

    
    
    
    'Delete Outlook items
    For Each Item In SubFolder.Items
    For Each Atmt In Item.attachments
    If Atmt.Type = 1 And InStr(Atmt, "xlsx") > 0 Then
    Item.Delete
    End If
    Next Atmt
    Next Item
   
    
    
  
    
    ' Clear memory
SaveAttachmentsToFolder_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: GetAttachments" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Resume SaveAttachmentsToFolder_exit

Open in new window

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015
Commented:
While deleting items from a collection, you should loop in reverse order.
Replace lines#34:40 with the following lines and it would work as desired.

Dim i As Long
For i = SubFolder.items.Count To 1 Step -1
    Set Item = SubFolder.items(i)
    For Each Atmt In Item.attachments
        If Atmt.Type = 1 And InStr(Atmt, "xlsx") > 0 Then
            Item.Delete
            Exit For
        End If
    Next Atmt
Next i

Open in new window

Jim Dettman (EE MVE)President / Owner
Most Valuable Expert 2017
Most Valuable Expert 2012

Commented:
This:

    For Each Item In SubFolder.Items
    For Each Atmt In Item.attachments
    If Atmt.Type = 1 And InStr(Atmt, "xlsx") > 0 Then
    Item.Delete
    End If
    Next Atmt
    Next Item

Open in new window


Doesn't seem right.....you should be setting a T/F flag for deleting the e-mail, not trying to delete it on every attachment check.   ie.:

 
    For Each Item In SubFolder.Items
    bolDeleteItem = False
    For Each Atmt In Item.attachments
      If Atmt.Type = 1 And InStr(Atmt, "xlsx") > 0 Then
        bolDeleteItem = True
      End If
    Next Atmt

    If bolDeleteItem = True then
     Item.Delete
    End If
    Next Item

Open in new window

Author

Commented:
Thanks Subodh
Subodh Tiwari (Neeraj)Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015

Commented:
You're welcome!

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial