Out of free memory while running archiver code in Outlook VBA. Office 365

Question

I have written a simple email archiver code to save emails from my outlook inbox that are more than 45 days old. Many of my coworkers and I use this code because our company disables the autoarchive functions of outlook. It may be important to note that I DID NOT receive this error prior to our company transitioning to Microsoft Office 365. Now when running my archiver code I get the following error message:

"Run-time error '-2147024882 (8007000e)': There is not enough free memory to run this program. Quit one or more programs, and then try again."

An important thing to note is that the code will run through 40-50 iterations (save 40-50 emails) and THEN throw this error message. My thinking after doing a little research is that one of the objects is building in size with each loop, but I can't figure out how that could be occurring. I also can't figure out a way to clear the free memory (I am not a very experienced coder). Once the error message has appeared the first time, subsequent runs of code throw the error immediately. The only remedy I have found is to restart the computer. After a restart it seems that the "free memory" has been cleared and this allows the code to run through another 40-50 cycles before again throwing the error. I assume I could put something in each loop to clear this free memory or eliminate the source of whatever variable is "building" with each iteration, but I am having a hard time understanding what that is with my research as many of the code examples are much more complex than mine. Sorry if I'm asking something that has already been answered but, as I said, my lack of experience with coding is making this research very difficult. Thanks!

Here is my full code:

 Sub SaveAgedMailMaster()



Dim objOutlook As Outlook.Application
 Dim objNamespace As Outlook.NameSpace
 Dim objSourceFolder As Outlook.MAPIFolder
 Dim objSubfolder As Outlook.MAPIFolder
 Dim objSubSubFolder As Outlook.MAPIFolder
 Dim objVariant As Variant
 Dim lngMovedItems As Long
 Dim intCount As Integer
 Dim intDateDiff As Integer
 Dim strDestFolder As String
 Dim sName As String
 Dim enviro As String
 Dim ernum As Integer
 Dim Nogood As Integer
 Dim Needmsg As Integer
 Dim ItemCount As Integer
 Dim Filepath As String




 enviro = CStr(Environ("USERPROFILE"))
 ernum = 0
 Needmsg = 0
 ItemCount = 0

 Set objOutlook = Application
 Set objNamespace = objOutlook.GetNamespace("MAPI")
 Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)




''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'saving inbox folder items

enviro = CStr(Environ("USERPROFILE"))
 ernum = 0
 Needmsg = 0
 ItemCount = 0

 Set objOutlook = Application
 Set objNamespace = objOutlook.GetNamespace("MAPI")
 Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)

 'set this to the directory of your choice
 spath = "C:\Users\djgatli\OneDrive - Duke Energy\Desktop\Email Archive\"
 spath2 = "\\nucvrnpfile\rnpdata\Engineering\Reactor\Gatlin, David\Email Archive\"


 For intCount = objSourceFolder.Items.Count To 1 Step -1
 Set objVariant = objSourceFolder.Items.Item(intCount)
 DoEvents

 'Comment the next line out so that all inbox items are archived. Otherwise all the calender events stay
 If objVariant.Class = olMail Then


 intDateDiff = DateDiff("d", objVariant.SentOn, Now)
 ' I'm using 45 days, adjust as needed.
 If intDateDiff > 45 Then

 Nogood = 1
 sName = objVariant.Subject
 ReplaceCharsForFileName sName, "_"
 dtDate = objVariant.ReceivedTime
 sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
     vbUseSystem) & Format(dtDate, "-hhnnss", _
     vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"




 On Error GoTo Erhandle
 objVariant.SaveAs spath & sName, olMSG
 objVariant.SaveAs spath2 & sName, olMSG
 objVariant.Delete
 Nogood = 0
 ItemCount = ItemCount + 1

Erhandle:
  If Nogood = 1 Then
    Needmsg = 1
    ermsg = ermsg & ", " & sName
  End If

 End If
 End If
 Next

 'comment out next IF block if no msgbox is wanted
If Needmsg = 1 Then

MsgBox ("Could not save backups of " & ermsg)
MsgBox (ItemCount & " Mailbox items were successfully archived in " & spath & " and " & spath2)

Else

MsgBox (ItemCount & " Mailbox items were successfully archived in " & spath & " and " & spath2)

End If



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Saving SENT mail folder


 enviro = CStr(Environ("USERPROFILE"))
 ernum = 0
 Needmsg = 0
 ItemCount = 0

 Set objOutlook = Application
 Set objNamespace = objOutlook.GetNamespace("MAPI")
 Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderSentMail)

 'set this to the directory of your choice
 spath = "C:\Users\djgatli\OneDrive - Duke Energy\Desktop\Email Archive\Sent\"
 spath2 = "\\nucvrnpfile\rnpdata\Engineering\Reactor\Gatlin, David\Email Archive\Sent\"


 For intCount = objSourceFolder.Items.Count To 1 Step -1
 Set objVariant = objSourceFolder.Items.Item(intCount)
 DoEvents

 'Commented the next line out so that all inbox items are archived. Otherwise all the calender events stay
 If objVariant.Class = olMail Then


 intDateDiff = DateDiff("d", objVariant.SentOn, Now)
 ' I'm using 45 days, adjust as needed.
 If intDateDiff > 45 Then

 Nogood = 1
 sName = objVariant.Subject
 ReplaceCharsForFileName sName, "_"
 dtDate = objVariant.ReceivedTime
 sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
     vbUseSystem) & Format(dtDate, "-hhnnss", _
     vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"




 On Error GoTo Erhandle2
 objVariant.SaveAs spath & sName, olMSG
 objVariant.SaveAs spath2 & sName, olMSG
 objVariant.Delete
 Nogood = 0
 ItemCount = ItemCount + 1

Erhandle2:
  If Nogood = 1 Then
    Needmsg = 1
    ermsg = ermsg & ", " & sName
  End If

 End If
 End If
 Next
'comment out next if block if no msgbox is wanted
If Needmsg = 1 Then

MsgBox ("Could not save backups of " & ermsg)
MsgBox (ItemCount & " Mailbox items were successfully archived in " & spath & " and " & spath2)

Else

MsgBox (ItemCount & " Mailbox items were successfully archived in " & spath & " and " & spath2)

End If

 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, Chr(34), sChr)
   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(9), sChr)
   sName = Replace(sName, Chr(10), sChr)
   sName = Replace(sName, Chr(11), sChr)
   sName = Replace(sName, Chr(12), sChr)
   sName = Replace(sName, Chr(13), sChr)

 End Sub

40-50 objects appears to be insignificant but try `Set objVariant = Nothing` before each of the `Next` statements. — niton, Sep 18 '18 at 19:27
You could use the VBA code analyzer tool to check the memory issue. However, if you reduce the loops and emails which such problems still exist? I'm not sure if it's the shared folder. In short, try to improve your code and refer to this link: https://stackoverflow.com/questions/14396998/how-to-clear-memory-to-prevent-out-of-memory-error-in-excel-vba — Simon Li, Sep 19 '18 at 12:17
I added the Set ObjVariant = Nothing Line to the end of the loop, but still the same error. It actually fails at the "objVariant.SaveAs spath & sName, olMSG" line (where the first save of the email is attempted). So the memory issue occurs during an attempt to save. Since this didn't occur before going to Office 365 it must be caused by the way the program is attempting to perform the save. I have no idea.... — BusinessMonkey, Sep 19 '18 at 14:13

score 0 · Answer 1 · answered Sep 20 '18 at 05:03

0

You are using multiple dot notation, which means the compiler creates implicit variables that you cannot explicitly release:

 For intCount = objSourceFolder.Items.Count To 1 Step -1
   Set objVariant = objSourceFolder.Items.Item(intCount)

You code needs to be

set vItems = objSourceFolder.Items
For intCount = vItems.Count To 1 Step -1
  Set objVariant = vItems.Item(intCount)
  ...
  set objVariant = Nothing
next

answered Sep 20 '18 at 05:03

Dmitry Streblechenko

62,942
4
53
78

Tried to run with this edit and got the same error... do i need to declare the vItems variable at the beginning of my code? If so, what variable type should be used? – BusinessMonkey Sep 24 '18 at 18:42
Yes, if you are using "Option explicit". Please show the rest of your code. Make sure you are not using multiple dot notation inside the loop. – Dmitry Streblechenko Sep 25 '18 at 01:10
Tried declaring the variable as "Variant". Still getting the same error. And I've posted every line of my code in the original post. What exactly do you mean by using "option explicit" is there some other piece of code I need to "enable" this option? (that's probably an incorrect understanding of what that actually means isn't it? Sorry, not up to snuff on coding language) – BusinessMonkey Sep 25 '18 at 10:27
Please edit your post to show your latest code. VBA allows to use undeclared variables unless "Option explicit" is specified - https://learn.microsoft.com/en-us/dotnet/visual-basic/language-reference/statements/option-explicit-statement – Dmitry Streblechenko Sep 25 '18 at 16:41

Out of free memory while running archiver code in Outlook VBA. Office 365

1 Answers1