Недостаточно памяти при выполнении кода архиватора в Outlook VBA.Офис 365 - PullRequest
Новая
       15

Недостаточно памяти при выполнении кода архиватора в Outlook VBA.Офис 365

0 голосов
/ 18 сентября 2018

Я написал простой код архиватора электронной почты, чтобы сохранять электронные письма из моего почтового ящика outlook старше 45 дней.Многие из моих коллег и я используем этот код, потому что наша компания отключает функции автоматического архивирования Outlook.Может быть важно отметить, что я НЕ получил эту ошибку до перехода нашей компании на Microsoft Office 365. Теперь при запуске кода моего архиватора я получаю следующее сообщение об ошибке:

«Ошибка времени выполнения» -2147024882(8007000e) ': Недостаточно свободной памяти для запуска этой программы. Закройте одну или несколько программ и повторите попытку. "

Важно отметить, что код будет проходить через 40-50 итераций(сохранить 40-50 писем), а затем выбросить это сообщение об ошибке.После небольшого исследования я думаю, что один из объектов строится с каждым циклом, но я не могу понять, как это могло произойти.Я также не могу найти способ очистить свободную память (я не очень опытный кодер).Как только сообщение об ошибке появилось в первый раз, последующие прогоны кода немедленно выдают ошибку.Единственное средство, которое я нашел, это перезагрузить компьютер.После перезапуска кажется, что «свободная память» очищена, и это позволяет коду проходить еще 40-50 циклов, прежде чем снова выдать ошибку.Я предполагаю, что я мог бы поместить что-то в каждый цикл, чтобы очистить эту свободную память или устранить источник любой переменной, которая «строится» с каждой итерацией, но мне трудно понять, что это такое с моими исследованиями, так как многие примеры кодагораздо сложнее, чем у меня.Извините, если я спрашиваю что-то, на что уже дан ответ, но, как я уже сказал, мой недостаток опыта в кодировании делает это исследование очень трудным.Спасибо!

Вот мой полный код: 

 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

1 Ответ

0 голосов
/ 20 сентября 2018

Вы используете многоточечную нотацию, что означает, что компилятор создает неявные переменные, которые вы не можете явно освободить: 

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

Ваш код должен быть 

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