Forum Discussion

Sameer_Kuppanath_Sultan's avatar
Sameer_Kuppanath_Sultan
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 E...
excel
  • HansVogelaar's avatar
    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
  • Sameer_Kuppanath_Sultan's avatar
    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 

    • HansVogelaar's avatar
      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
      • Sameer_Kuppanath_Sultan's avatar
        Sameer_Kuppanath_Sultan
        Brass Contributor
        May 17, 2021

        Hi HansVogelaar 

         

        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??

         

         

Resources