May 16 2021 06:48 AM
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
May 16 2021 07:01 AM
May 16 2021 11:45 PM
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
May 17 2021 01:08 AM
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
May 17 2021 03:17 AM
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??
May 17 2021 04:03 AM
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
May 17 2021 04:05 AM
May 17 2021 06:37 AM
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
May 17 2021 07:00 AM
SolutionChange 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
May 17 2021 07:03 AM
May 17 2021 07:00 AM
SolutionChange 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