Brass Contributor

May 16, 2021

VBA code to remove all mails from a specified Folders in Excel

Hi All

I need a help from you guys.

I have the below code, that help me to download all the attachments from outlook mails from a specified folder in outlook by clicking Command button from Excel. I want either delete or move these mails from the folder to temp folder after doing the same above in a same click. Please let me know what changes to be needed or not??

Option Explicit

Private Sub CommandButton1_Click()

Dim OlApp As Object
Dim Olmail As Object
Dim Olitems As Object
Dim Olfolder As Object
Dim j As Integer
Dim Strfolder As String
Dim FilePath As String
Dim OlfolderSub As Object
Dim ns As Object
Dim inboxFol As Object
Dim subFol As Object 'Outlook.Folder

Set OlApp = GetObject(, "Outlook.application")
If Err.Number = 429 Then
Set OlApp = CreateObject("Outlook.Application")
End If

Strfolder = "C:\Work Area\OutlookAttachments" 'change extract to the folder name where you would like to have your attacment

Set Olfolder = OlApp.GetNamespace("MAPI").Folders("xyz@company.com").Folders("Inbox").Folders("Work in Progress (FC)")

Set ns = OlApp.GetNamespace("MAPI")
Set inboxFol = ns.GetDefaultFolder(6)
Set subFol = inboxFol.Folders("Temp")

Set Olitems = Olfolder.Items

For Each Olmail In Olitems
If Olmail.Attachments.Count > 0 Then
For j = 1 To Olmail.Attachments.Count

FilePath = Strfolder & "\" & Olmail.Attachments.Item(j).fileName
Olmail.Attachments.Item(j).SaveAsFile FilePath

Olmail.UnRead = False

'Olmail.Move subFol
Next j
End If

Next

Set Olfolder = Nothing
Set Olitems = Nothing
Set Olmail = Nothing
Set OlApp = Nothing

End Sub

excel

HansVogelaar

May 17, 2021

Sameer_Kuppanath_Sultan

Change that line to

olMail.Delete

This will move the email to your Deleted Items folder. You can set Outlook to automatically empty this folder when you quit the application, or you can add code to your macro to empty it.

Private Sub CommandButton1_Click()
    Dim olApp As Object
    Dim olMail As Object
    Dim olItems As Object
    Dim ns As Object
    Dim olFolder As Object
    Dim olFolderSub As Object
    Dim olInbox As Object
    Dim i As Long
    Dim j As Integer
    Dim Strfolder As String
    Dim FilePath As String

    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        Set olApp = CreateObject("Outlook.Application")
    End If

    Strfolder = "C:\Work Area\OutlookAttachments"

    Set ns = olApp.GetNamespace("MAPI")
    Set olFolder = ns.Folders("xyz@company.com").Folders("Inbox").Folders("Work in Progress (FC)")
    Set olInbox = ns.GetDefaultFolder(6)
    Set olItems = olFolder.Items

    For i = olItems.Count To 1 Step -1
        Set olMail = olItems.Item(i)
        If olMail.Attachments.Count > 0 Then
            For j = 1 To olMail.Attachments.Count
                FilePath = Strfolder & "\" & olMail.Attachments.Item(j).Filename
                olMail.Attachments.Item(j).SaveAsFile FilePath
            Next j
        End If
        olMail.UnRead = False
        olMail.Delete
    Next i

    Set olFolder = ns.Folders("xyz@company.com").Folders("Inbox").Folders("Deleted Items")
    Set olItems = olFolder.Items
    For i = olItems.Count To 1 Step -1
        Set olMail = olItems.Item(i)
        olMail.Delete
    Next i

    Set olFolder = Nothing
    Set olItems = Nothing
    Set olMail = Nothing
    Set olApp = Nothing
End Sub

HansVogelaar

MVP

May 16, 2021

Sameer_Kuppanath_Sultan

Have you tried uncommenting the line

'Olmail.Move subFol

Sameer_Kuppanath_Sultan

Brass Contributor

May 17, 2021

Yeah, I have tried.

But some of them are moving, and the rest remain in the same folder. (Work in Progress (FC)).

For Each Olmail In Olitems
If Olmail.Attachments.Count > 0 Then
For j = 1 To Olmail.Attachments.Count

FilePath = Strfolder & "\" & Olmail.Attachments.Item(j).fileName
Olmail.Attachments.Item(j).SaveAsFile FilePath

Olmail.UnRead = False

Olmail.Move subFol
Next j

HansVogelaar

MVP

May 17, 2021

Sameer_Kuppanath_Sultan

If you want to move only messages that have attachments:

Private Sub CommandButton1_Click()
    Dim olApp As Object
    Dim olMail As Object
    Dim olItems As Object
    Dim ns As Object
    Dim olFolder As Object
    Dim olFolderSub As Object
    Dim olInbox As Object
    Dim j As Integer
    Dim Strfolder As String
    Dim FilePath As String

    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        Set olApp = CreateObject("Outlook.Application")
    End If

    Strfolder = "C:\Work Area\OutlookAttachments"

    Set ns = olApp.GetNamespace("MAPI")
    Set olFolder = ns.Folders("xyz@company.com").Folders("Inbox").Folders("Work in Progress (FC)")
    Set olInbox = ns.GetDefaultFolder(6)
    Set olFolderSub = olInbox.Folders("Temp")
    Set olItems = olFolder.Items

    For Each olMail In olItems
        If olMail.Attachments.Count > 0 Then
            For j = 1 To olMail.Attachments.Count
                FilePath = Strfolder & "\" & olMail.Attachments.Item(j).Filename
                olMail.Attachments.Item(j).SaveAsFile FilePath
            Next j
            olMail.UnRead = False
            olMail.Move olFolderSub
        End If
    Next olMail

    Set olFolder = Nothing
    Set olItems = Nothing
    Set olMail = Nothing
    Set olApp = Nothing
End Sub

If you want to move ALL messages in the folder:

Private Sub CommandButton1_Click()
    Dim olApp As Object
    Dim olMail As Object
    Dim olItems As Object
    Dim ns As Object
    Dim olFolder As Object
    Dim olFolderSub As Object
    Dim olInbox As Object
    Dim j As Integer
    Dim Strfolder As String
    Dim FilePath As String

    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        Set olApp = CreateObject("Outlook.Application")
    End If

    Strfolder = "C:\Work Area\OutlookAttachments"

    Set ns = olApp.GetNamespace("MAPI")
    Set olFolder = ns.Folders("xyz@company.com").Folders("Inbox").Folders("Work in Progress (FC)")
    Set olInbox = ns.GetDefaultFolder(6)
    Set olFolderSub = olInbox.Folders("Temp")
    Set olItems = olFolder.Items

    For Each olMail In olItems
        If olMail.Attachments.Count > 0 Then
            For j = 1 To olMail.Attachments.Count
                FilePath = Strfolder & "\" & olMail.Attachments.Item(j).Filename
                olMail.Attachments.Item(j).SaveAsFile FilePath
            Next j
        End If
        olMail.UnRead = False
        olMail.Move olFolderSub
    Next olMail

    Set olFolder = Nothing
    Set olItems = Nothing
    Set olMail = Nothing
    Set olApp = Nothing
End Sub

NikolinoDE
Gold Contributor
May 17, 2021
It doesn't delete the unread emails as far as I could understand. It has to be read in order to be considered as filed in the folder.
Mark all your e-mails as read and then run through the code, maybe it'll work :))

It's just an idea, but who am I? I just know that I don't know

Cheers
Nikolino

Forum Discussion

VBA code to remove all mails from a specified Folders in Excel

Share

Resources