Items.restrict method to look for items that are sent today - vba

I'm trying to write a code to download weekly assignments (attachments) and save it to a folder.
I got a code which goes through every item and downloads all the attachments but it goes from latest to earliest date. I need the latest one as the earlier attachments will overwrite the later ones.
I added a restrict method to look for items that are sent today but it still goes through the whole inbox.
Sub downloadAttachment()
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim myItems As Items
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim sFilter As String
'Setting variable for inbox.
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
**sFilter = "[ReceivedTime]>=""&Date()12:00am&"""
Set myItems = Inbox.Items.Restrict(sFilter)**
i = 0
'Error handling.
On Error GoTo downloadattachment_err
'if no attachments, msgbox displays.
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
'Goes through each item in inbox for attachments.
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "txt" Then
FileName = "C:\losscontroldbases\pendingworkdownload\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
'If attachments found, the displays message.
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\losscontroldbases\pendingworkdownload." _
& vbCrLf & "Have a nice day!"
Else
MsgBox "I didn't find any attached files in your mail."
End If
'Clearing memory.
downloadattachment_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
'Error handling code.
downloadattachment_err:
MsgBox " An unexpected error has occured."
End Sub

Your code references "date" string as a literal value. Use something like
Filter = "[ReceivedTime]>= '" & CStr(Date()) & " 12:00am' "

Related

Finding specific email Subject in Outlook sub folder and download attached files from the email

I have managed to make macro that downloads attachments files from my Inbox sub folder in Outlook, but it seems i can't make it works for specific combination of symbols in the email subject.
I need to download only the attachments from email that contains "906" in the Subject name. Can someone makes the modification i need for this task, please? I'm stuck already in my code :
Sub SaveMail()
SaveEmailAttachmentsToFolder "Meteologica SA Power Forecast", "csv", ""
End Sub
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim item As Object
Dim Att As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
Dim strAttachmentName As String
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
I = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
For Each item In SubFolder.Items
For Each Att In item.Attachments
If LCase(Right(Att.FileName, Len(ExtString))) = LCase(ExtString) And InStr(strAttachmentName, "906") > 0 Then
DestFolder = "C:\Users\Confi-005\OneDrive - confi.com\Desktop\Schedule\Mail_Temp\Download\"
FileName = DestFolder & item.SenderName & " " & Att.FileName
Att.SaveAsFile FileName
I = I + 1
End If
Next Att
Next item
If I > 0 Then
MsgBox "You can find the files here : " _
& DestFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit
End Sub
Iterating over all items in the folder is not really a good idea:
For Each item In SubFolder.Items
For Each Att In item.Attachments
Instead, you need to use the Find/FindNext or Restrict methods of the Items class where you can deal only with items that correspond to the specified search criteria. You may find these methods described in depth in the articles that I wrote for the technical blog:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
For example, you may use the following search criteria to find items with a specific phrase in the Subject line:
criteria = "#SQL=" & Chr(34) _
& "urn:schemas:httpmail:subject" & Chr(34) _
& " ci_phrasematch 'question'"
Read more about that in the Filtering Items Using a String Comparison article.

Adding an Appointment sent as an Attachment to a Calendar

Automated emails with .ics attachments are being received in an Outlook Shared mailbox.
I am trying to open that attachment, and save that Meeting/Appointment to the Calendar.
I tried a number of ways. For my latest iteration I am hoping to add this macro directly on the Shared Calendar's mailbox. Let me know if it makes more sense for the emails to be sent to my personal Outlook mailbox, where I then call the macro from a "run a script" Outlook Rule, and route it to the Shared Calendar.
Sub SaveAttatchments()
' This Outlook macro checks at the Outlook Inbox for messages
' with attached files (of *.ics type) and put a entry in the calendar.
On Error GoTo SaveAttachments_err
Dim InboxFolder As Outlook.Folder
Dim myCalendarFolder As Outlook.Folder
Dim myMtgReq As Outlook.MeetingItem
Dim mynamespace As Outlook.NameSpace
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set mynamespace = Application.GetNamespace("MAPI")
Set InboxFolder = mynamespace.GetDefaultFolder(olFolderInbox)
Set myCalendarFolder = mynamespace.GetDefaultFolder(olFolderCalendar)
FilePath = "C:\temp\"
' Check each message for attachments
For Each Item In InboxFolder.Items
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "ics" Then
'Save the attachment in folder
FileName = FilePath & Atmt.FileName
Atmt.SaveAsFile FileName
'Import the ics from the folder and put an entry in Calendar
Set myMtgReq = mynamespace.OpenSharedFolder(FileName)
myMtgReq.GetAssociatedAppointment (True)
i = i + 1
End If
Next Atmt
Next Item
SaveAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set myMtgReq = Nothing
Exit Sub
SaveAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachments_exit
End Sub
I get the following:
"Outlook cannot perform this action on this type of attachment."
Below is the corrected vba. The Attachment saves as a AppointmentItem, not a MeetingItem, which was causing the issues.
Sub SaveAttatchments()
On Error GoTo SaveAttachments_err
Dim myNameSpace As Outlook.NameSpace
Dim InboxFolder As Outlook.Folder
Dim myCalendarFolder As Outlook.Folder
Dim myMtgReq As Outlook.MeetingItem
Dim myAppt As Outlook.AppointmentItem
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set myNameSpace = Application.GetNamespace("MAPI")
Set InboxFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myCalendarFolder = myNameSpace.GetDefaultFolder(olFolderCalendar)
FilePath = "C:\temp\"
' Check each message for attachments
For Each Item In InboxFolder.Items
If Item.Subject = "Conf Calendar" Then
For Each Atmt In Item.Attachments
'Save the attachment in folder
FileName = FilePath & Atmt.FileName
Atmt.SaveAsFile FileName
'Import the ics from the folder and put an entry in Calendar
Set myAppt = myNameSpace.OpenSharedItem(FileName)
myAppt.Save
i = i + 1
Next Atmt
End If
Next Item
' Clear memory
SaveAttachments_exit:
Set Atmt = Nothing
Set Item= Nothing
Set myMtgReq = Nothing
Exit Sub
SaveAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachments_exit
End Sub

Remove duplicate Outlook items from a folder

issue
Outlook 2016 corrupted while I was moving items from an online archive into a pst file.
The PST file has been recovered .... but many items (~7000) are duplicated 5 times
There are a range of item types, standard messages, meeting requests etc
what I tried
I looked at existing solutions and tools, including:
duplicate removal tools - none of which were free other than a trial option to remove 10 items at a time.
A variety of code solutions including:
Jacob Hilderbrand's effort which runs from Excel
Macro in Outlook to delete duplicate emails-
I decided to go the code route as it was relatively simple and to gain more control over how the duplicates were reported.
I will post my self solution below as it may help others.
I would like to see other potential approaches (perhaps powershell) to fixing this problem which may be better than mine.
The approach below:
Provides users with a prompt to select the folder to process
Checks duplicates on the base of Subject, Sender, CreationTime and Size
Moved (rather than delete) any duplicates into a sub-folder (removed items) of the folder being processed.
Create a CSV file - stored under the path in StrPath to create a external reference to Outlook of the emails that have been moved.
Updated: Checking for size surprisingly missed a number of dupes, even for otherwise identical mail items. I have changed the test to subject and body
Tested on Outlook 2016
Const strPath = "c:\temp\deleted msg.csv"
Sub DeleteDuplicateEmails()
Dim lngCnt As Long
Dim objMail As Object
Dim objFSO As Object
Dim objTF As Object
Dim objDic As Object
Dim objItem As Object
Dim olApp As Outlook.Application
Dim olNS As NameSpace
Dim olFolder As Folder
Dim olFolder2 As Folder
Dim strCheck As String
Set objDic = CreateObject("scripting.dictionary")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.CreateTextFile(strPath)
objTF.WriteLine "Subject"
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
If olFolder Is Nothing Then Exit Sub
On Error Resume Next
Set olFolder2 = olFolder.Folders("removed items")
On Error GoTo 0
If olFolder2 Is Nothing Then Set olFolder2 = olFolder.Folders.Add("removed items")
For lngCnt = olFolder.Items.Count To 1 Step -1
Set objItem = olFolder.Items(lngCnt)
strCheck = objItem.Subject & "," & objItem.Body & ","
strCheck = Replace(strCheck, ", ", Chr(32))
If objDic.Exists(strCheck) Then
objItem.Move olFolder2
objTF.WriteLine Replace(objItem.Subject, ", ", Chr(32))
Else
objDic.Add strCheck, True
End If
Next
If objTF.Line > 2 Then
MsgBox "duplicate items were removed to ""removed items""", vbCritical, "See " & strPath & " for details"
Else
MsgBox "No duplicates found"
End If
End Sub
Here's a script that takes advantage of sorting emails to check for duplicates much more efficiently.
There's no need to maintain a giant dictionary of every email you've seen if you are processing emails in a deterministic order (e.g. received date). Once the date changes, you know you'll never see another email with the prior date, therefore, they won't be duplicates, so you can clear your dictionary on each date change.
This script also takes into account the fact that some items use an HTMLBody for the full message definition, and others don't have that property.
Sub DeleteDuplicateEmails()
Dim allMails As Outlook.Items
Dim objMail As Object, objDic As Object, objLastMail As Object
Dim olFolder As Folder, olDuplicatesFolder As Folder
Dim strCheck As String
Dim received As Date, lastReceived As Date
Set objDic = CreateObject("scripting.dictionary")
With Outlook.Application.GetNamespace("MAPI")
Set olFolder = .PickFolder
End With
If olFolder Is Nothing Then Exit Sub
On Error Resume Next
Set olDuplicatesFolder = olFolder.Folders("Duplicates")
On Error GoTo 0
If olDuplicatesFolder Is Nothing Then Set olDuplicatesFolder = olFolder.Folders.Add("Duplicates")
Debug.Print "Sorting " & olFolder.Name & " by ReceivedTime..."
Set allMails = olFolder.Items
allMails.Sort "[ReceivedTime]", True
Dim totalCount As Long, index As Long
totalCount = allMails.count
Debug.Print totalCount & " Items to Process..."
lastReceived = "1/1/1987"
For index = totalCount - 1 To 1 Step -1
Set objMail = allMails(index)
received = objMail.ReceivedTime
If received < lastReceived Then
Debug.Print "Error: Expected emails to be in order of date recieved. Previous mail was " & lastReceived _
& " current is " & received
Exit Sub
ElseIf received = lastReceived Then
' Might be a duplicate track mail contents until this recieved time changes.
' Add the last mail to the dictionary if it hasn't been tracked yet
If Not objLastMail Is Nothing Then
Debug.Print "Found multiple emais recieved at " & lastReceived & ", checking for duplicates..."
objDic.Add GetMailKey(objLastMail), True
End If
' Now check the current mail item to see if it's a duplicate
strCheck = GetMailKey(objMail)
If objDic.Exists(strCheck) Then
Debug.Print "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
objMail.Move olDuplicatesFolder
DoEvents
Else
objDic.Add strCheck, True
End If
' No need to track the last mail, since we have it in the dictionary
Set objLastMail = Nothing
Else
' This can't be a duplicate, it has a different date, reset our dictionary
objDic.RemoveAll
lastReceived = received
' Keep track of this mail in case we end up needing to build a dictionary
Set objLastMail = objMail
End If
' Progress update
If index Mod 10 = 0 Then
Debug.Print index & " Remaining..."
End If
DoEvents
Next
Debug.Print "Finished moving Duplicate Emails"
End Sub
And the helper function referenced above for "uniquely identifying" an email. Adapt as needed, but I think if the subject and full body are the same, there's no point in checking anything else. Also works for calendar invites, etc.:
Function GetMailKey(ByRef objMail As Object) As String
On Error GoTo NoHTML
GetMailKey = objMail.Subject & objMail.HTMLBody
Exit Function
BodyKey:
On Error GoTo 0
GetMailKey = objMail.Subject & objMail.Body
Exit Function
NoHTML:
Err.Clear
Resume BodyKey
End Function
I've wrote a VBA script called "Outlook Duplicated Items Remover"
The source code is available on GitHub
It will find all duplicated items in a folder and its subfolders and move them to a dedicated folder
I simplified the duplicate search as in my case I imported multiple duplicates from PST files but the full mail body didn't match. I don't know why, as I am sure those mail are true duplicates.
My simplification is to match ONLY the receive TIME STAMP and the SUBJECT.
I added an error exception for an error I got some times on the function: Set olDuplicatesFolder = olFolder.Folders("Duplicates").
I did a different format for the debug.print messages.
Attribute VB_Name = "DelDupEmails_DATE_SUBJECT"
Sub DeleteDuplicateEmails_DATE_SUBJECT()
Dim allMails As Outlook.Items
Dim objMail As Object, objDic As Object, objLastMail As Object
Dim olFolder As Folder, olDuplicatesFolder As Folder
Dim strCheck As String
Dim received As Date, lastReceived As Date
Set objDic = CreateObject("scripting.dictionary")
With Outlook.Application.GetNamespace("MAPI")
Set olFolder = .PickFolder
End With
If olFolder Is Nothing Then Exit Sub
On Error Resume Next
Set olDuplicatesFolder = olFolder.Folders("Duplicates")
On Error GoTo 0
If olDuplicatesFolder Is Nothing Then Set olDuplicatesFolder = olFolder.Folders.Add("Duplicates")
Debug.Print "Sorting " & olFolder.Name & " by ReceivedTime..."
Set allMails = olFolder.Items
allMails.Sort "[ReceivedTime]", True
Dim totalCount As Long, index As Long
totalCount = allMails.Count
Debug.Print totalCount & " Items to Process..."
'MsgBox totalCount & " Items to Process..."
lastReceived = "1/1/1987"
For index = totalCount - 1 To 1 Step -1
Set objMail = allMails(index)
On Error Resume Next
received = objMail.ReceivedTime
On Error GoTo 0
If received < lastReceived Then
Debug.Print "Error: Expected emails to be in order of date recieved. Previous mail was " & lastReceived _
& " current is " & received
Exit Sub
ElseIf received = lastReceived Then
' Might be a duplicate track mail contents until this recieved time changes.
' Add the last mail to the dictionary if it hasn't been tracked yet
If Not objLastMail Is Nothing Then
Debug.Print olFolder & " : Found multiple emails recieved at " & lastReceived & ", checking for duplicates..."
'MsgBox "Found multiple emails recieved at " & lastReceived & ", checking for duplicates..."
objDic.Add GetMailKey(objLastMail), True
End If
' Now check the current mail item to see if it's a duplicate
strCheck = GetMailKey(objMail)
If objDic.Exists(strCheck) Then
Debug.Print "#" & index & " - Duplicate: " & lastReceived & " " & objMail.Subject
'Debug.Print "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
'MsgBox "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
objMail.Move olDuplicatesFolder
DoEvents
Else
objDic.Add strCheck, True
End If
' No need to track the last mail, since we have it in the dictionary
Set objLastMail = Nothing
Else
' This can't be a duplicate, it has a different date, reset our dictionary
objDic.RemoveAll
lastReceived = received
' Keep track of this mail in case we end up needing to build a dictionary
Set objLastMail = objMail
End If
' Progress update
If index Mod 100 = 0 Then
Debug.Print index & " Remaining... from " & olFolder
'MsgBox index & " Remaining..."
End If
DoEvents
Next
Debug.Print "Finished moving Duplicate Emails"
MsgBox "Finished moving Duplicate Emails"
End Sub
Function GetMailKey(ByRef objMail As Object) As String
On Error GoTo NoHTML
'GetMailKey = objMail.Subject & objMail.HTMLBody
GetMailKey = objMail.Subject ' & objMail.HTMLBody
Exit Function
BodyKey:
On Error GoTo 0
'GetMailKey = objMail.Subject & objMail.Body
GetMailKey = objMail.Subject ' & objMail.Body
Exit Function
NoHTML:
Err.Clear
Resume BodyKey
End Function

Outlook VBA - Error 424 Object Required error - but I can't work out why

We get hundreds of invoices emailed in per day - all are PDF format, and for most members of my dept, they're doing nothing more than marking them as read and moving them to a folder. My folder is called "invoices" and is a subfolder to my Inbox. I have written the following code, it throws an error 424 on the lines:
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
All I'm trying to do is check if an email is unread and has a pdf attachment, then move it to my "invoices" folder. Code follows:
Sub Lazy()
On Error GoTo Lazy_err
' Declare the variables
Dim ns As NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim Item As Object
Dim Atmt As Attachment
Dim i As Integer
' Set variables
Set ns = GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = myInbox.Folders("invoices")
i = 0
' If statement to check if there's any unread emails in the box
If Inbox.UnReadItemCount = 0 Then
MsgBox "There are no unread messages in your Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
If Item.UnRead = True Then
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "pdf" Then
myItem.Move myDestFolder
Item.UnRead = False
i = i + 1
End If
Next Atmt
' close off If statements, then move to next item and start again
End If
Next Item
' Display a summary message!
If i > 0 Then
MsgBox "I found " & i & " emails." _
& vbCrLf & "I have moved them into the correct folder." _
& vbCrLf & vbCrLf & "Maybe double check to make sure nothing else has been moved?", vbInformation, "Finished!"
Else
MsgBox "There's nothing to find", vbInformation, _
"Finished!"
End If
' Housekeeping - reset everything for next time macro is run
Lazy_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
' Exit the macro :)
Exit Sub
' Error Handler - goes at very end of script, even after "exit sub"
Lazy_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume Lazy_exit
End Sub
First of all, you need to correct the namespace variable name as Paul suggested:
' Set variables
Set ns = GetNamespace("MAPI")
Set myInbox = ns.GetDefaultFolder(olFolderInbox)
Then I have noticed the following lines of code:
For Each Item In Inbox.Items
If Item.UnRead = True Then
Don't iterate over all items in the folder. It will take a lot of time and may cause issues related to not releasing objects in time. Use the Find/FindNext or Restrict methods of the Items class instead. You can read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
You have created/initialized a Namespace Object variable ns, but not myNameSpace. Make sure you modify your code to reference appropriate objects.
Sub Lazy()
On Error GoTo Lazy_err
' Declare the variables
Dim ns As NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim Item As Object
Dim Atmt As Attachment
Dim i As Integer
' Set variables
Set ns = GetNamespace("MAPI")
Set myInbox = ns.GetDefaultFolder(olFolderInbox)
'Code continues...

Saving Outlook Attachments

working with VBA in Outlook and am struggling with levelled folders when locating as it seems to only work a one levelled 'sub level'. I currently have probably a 5 tier folder organisation in my outlook, and daily I will get many emails which have attachments that need to be filed.
So far I'm working with my first folder to extract attachments and file them in a designated folder I have made but it wont work as the subfolder is in the 4th tier.
Sub GetAttachments()
On Error GoTo GetAttachments_err
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("DZ1")
i = 0
' Check Inbox for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Sales Reports folder." _
, vbInformation, "Nothing Found"
Exit Sub
End If
' Check each message for attachments
If SubFolder.Items.Count > 0 Then
For Each Item In SubFolder.Items
' Save any attachments found
For Each Atmt In Item.Attachments
FileName = "File path" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
End If
' Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle errors
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub
Can I please get some help?
Cheers
You need to refactor your code so that the operations that are performed in a folder is in a recursive method that calls itself when it needs to access another folder in the folder's Folder.Folders collection.
Follow the path as if you were getting the folder manually.
Set SubFolder = Inbox.Folders("DZ1").Folders("DZ2").Folders("DZ3").Folders("DZ4")
just searching subfolders will reeally only check direct subfolders. not "grandchildren".
You would have to do something like:
Sub subfolderrs_6_levels()
Dim Ol, Mf, Mf1, mf2, Ns, mf3, mf4, mf5, mf6, I&
On Error Resume Next
For Each Mf In Ns.Folders
call_your_routine(mf)
I = I + 1
For Each Mf1 In Mf.Folders
call_your_routine(mf1)
I = I + 1
For Each mf2 In Mf1.Folders
call_your_routine(mf2)
I = I + 1
For Each mf3 In mf2.Folders
call_your_routine(mf3)
I = I + 1
For Each mf4 In mf3.Folders
call_your_routine(mf4)
I = I + 1
For Each mf5 In mf4.Folders
call_your_routine(mf5)
I = I + 1
For Each mf6 In mf5.Folders
call_your_routine(mf6)
Next
Next
Next
Next
Next
Next
Next
Set Ns = Nothing: Set Mf1 = Nothing: Set Mf = Nothing: Set Ol = Nothing:
Set mf2 = Nothing: Set mf3 = Nothing: Set mf4 = Nothing: Set mf5 = Nothing: Set mf6 = Nothing
End Sub
sub call_your_routine(mf as Outlook.folder)
For Each Item In SubFolder.Items
' Save any attachments found
For Each Atmt In Item.Attachments
FileName = "File path" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
end sub