CODEWITHSUNDEEP
vbaoutlook
JCO007
JCO007

Reputation: 1

Looping through selection opens too many items

I have been tasked with finding a way to easily save large numbers of email attachments.

I found code here: https://www.slipstick.com/developer/code-samples/save-rename-outlook-email-attachments/
This requires the user to apply search terms to get their list of emails (e.g. received:27/02/2022 & keyword) then select all and run the macro.

For a large selection I get the message:

Your server administrator has limited the number of items you can open simultaneously. Try closing messages you have opened or removing attachments and images from unsent messages you are composing.

I understand that there are some built in limitations in Outlook and that the items remain open until the loop is closed.

Public Sub saveAttachtoDisk()
Dim itm As Outlook.MailItem
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim strSubject As String, strExt As String
Dim objAtt As Outlook.Attachment
Dim saveFolder As String

Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
saveFolder = enviro & "\OneDrive - Deloitte (O365D)\Desktop\Attachment_Download\"

Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection

For Each itm In Selection
 For Each objAtt In itm.Attachments
  ' get the last 5 characters for the file extension
  strExt = Right(objAtt.DisplayName, 5)
  ' clean the subject
  strSubject = Left(itm.Subject, 100)
  ReplaceCharsForFileName strSubject, "-"

  ' put the name and extension together
  File = saveFolder & strSubject & strExt
 
  objAtt.SaveAsFile File
 Next
Next
 
Set objAtt = Nothing
End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

I tried setting item to nothing within the loop:

For Each itm In Selection
 For Each objAtt In itm.Attachments
  ' get the last 5 characters for the file extension
  strExt = Right(objAtt.DisplayName, 5)
  ' clean the subject
  strSubject = Left(itm.Subject, 100)
  ReplaceCharsForFileName strSubject, "-"

  ' put the name and extension together
  File = saveFolder & strSubject & strExt
 
  objAtt.SaveAsFile File
  Set itm = Nothing
 Next
Next
 
Set objAtt = Nothing
End Sub

The mailbox is running in 'Use cached exchange mode' (I cannot change this) with 'download shared folders' unticked.

I understand from searching other threads that the "for each" loop keeps all items referenced until the loop ends.

Similar questions suggested the use of MAPITable.GetTable but I haven't been able to find any example using this.

Upvotes: 0

Views: 137

Answers (1)

Dmitry Streblechenko
Dmitry Streblechenko

Reputation: 66255

A couple things you can do:

  1. Turn cached mode on - the error only occurs in online stores. Cached stores are not subject to the limit as your code would only be touching local objects.

  2. Do not use for each loops - they keep all their items referenced until the loop exits, use simple for loops.

    for i = 1 to Selection.Count
      set itm  = Selection(i)
      set attachments = itm.Attachments
      for j = 1 to attachments.Count
       set attach = attachments(j)
       ...
       set attach = Nothing
      next j
      set attachments = Nothing
      set itm = Nothing
    next i

Upvotes: 0

Related Questions