SOLVED

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

Brass Contributor

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

 

 

 

9 Replies

@Sameer_Kuppanath_Sultan 

Have you tried uncommenting the line

 

'Olmail.Move subFol

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

 

@Hans Vogelaar 

@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

Hi @Hans Vogelaar 

 

Thanks for the code, but when I run the code, some of the mails are still in that folder.

 There were 7 mails in the folder, After I run the code, 3 remains in the folder as below image. 

Is there any problem with loop??

 

Sameer_Kuppanath_Sultan_0-1621246681803.png

 

@Sameer_Kuppanath_Sultan 

Does this work?

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 olFolderSub = olInbox.Folders("Temp")
    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.Move olFolderSub
    Next i

    Set olFolder = Nothing
    Set olItems = Nothing
    Set olMail = Nothing
    Set olApp = Nothing
End Sub
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

Hi @Hans Vogelaar 

Finally You saved my day.

 

Just to add it, if I want to delete the mails permanently instead of moving to "temp" folder,  could you please tell me what changes to be done in the code

 

olMail.Move olFolderSub

 

 

 

best response confirmed by Sameer_Kuppanath_Sultan (Brass Contributor)
Solution

@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

Hi @Hans Vogelaar 

 

Thanks a lot

 

"You are Awesome!'

1 best response

Accepted Solutions
best response confirmed by Sameer_Kuppanath_Sultan (Brass Contributor)
Solution

@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

View solution in original post