Sub CloseWithoutAttachments()
Const olMail = 43, olDiscard = 1, olPromptForSave = 2
Dim i As Long
Dim Inspector As Object
On Error Resume Next
With GetObject(, "Outlook.Application")
If Err Then
MsgBox "Outlook not open", vbExclamation, "Exit"
Exit Sub
End If
For Each Inspector In .Inspectors
With Inspector.CurrentItem
If .Class = olMail Then
If .Attachments.Count = 0 Then
i = i + 1
Inspector.Close olDiscard ' or use olPromptForSave instead of olDiscard
End If
End If
End With
Next
End With
MsgBox "Closed emails without attachments: " & i, vbInformation
End Sub
Hi and welcome to MrExcel board!
Play with the below code:
RegardsRich (BB code):Sub CloseWithoutAttachments() Const olMail = 43, olDiscard = 1, olPromptForSave = 2 Dim i As Long Dim Inspector As Object On Error Resume Next With GetObject(, "Outlook.Application") If Err Then MsgBox "Outlook not open", vbExclamation, "Exit" Exit Sub End If For Each Inspector In .Inspectors With Inspector.CurrentItem If .Class = olMail Then If .Attachments.Count = 0 Then i = i + 1 Inspector.Close olDiscard ' or use olPromptForSave instead of olDiscard End If End If End With Next End With MsgBox "Closed emails without attachments: " & i, vbInformation End Sub