Run-time error '-2147024882 (8007000e)'

[Adam81]

I am trying to put together a project to save e-mails to a folder. After 51 e-mails are saved to .../MyEmails I am getting the error below:

Run-time error '-2147024882 (8007000e)'

There is not enough free memory to run this program. Quit one or more programs, and then try again.

So I increased my virtual memory from 1280MB to 4000MB and I get the same error message (after 51 e-mails are saved).

Option Explicit
Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String
  
  enviro = CStr(Environ("USERPROFILE"))
  sPath = enviro & "\Documents\MyEmails\"
  
  For Each objItem In ActiveExplorer.Selection
    If objItem.MessageClass = "IPM.Note" Then
      Set oMail = objItem
   
      'get name and remove special characters
      sName = oMail.Subject
      sName = Replace(sName, "'", "-")
      sName = Replace(sName, "*", "-")
      sName = Replace(sName, "/", "-")
      sName = Replace(sName, "\", "-")
      sName = Replace(sName, ":", "-")
      sName = Replace(sName, "?", "-")
      sName = Replace(sName, Chr(34), "-")
      sName = Replace(sName, "<", "-")
      sName = Replace(sName, ">", "-")
      sName = Replace(sName, "|", "-")
 
      dtDate = oMail.ReceivedTime
      sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
        vbUseSystem) & Format(dtDate, "-hhnnss", _
        vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
         
      oMail.SaveAs sPath & sName, olMSG
    End If
  Next
End Sub

I am using Outlook 2013, Windows 10 Pro V 1709.

Thanks
Adam

[gmayor]

A couple of small changes might help - but I would suggest that you investigate the message it stops at to see why that should be.

Public Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String

    enviro = CStr(Environ("USERPROFILE"))
    sPath = enviro & "\Documents\MyEmails\"

    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem

            'get name and remove special characters
            sName = Left(oMail.Subject, 100)    'limit the length of the subject
            sName = Replace(sName, "'", "-")
            sName = Replace(sName, "*", "-")
            sName = Replace(sName, "/", "-")
            sName = Replace(sName, "\", "-")
            sName = Replace(sName, ":", "-")
            sName = Replace(sName, "?", "-")
            sName = Replace(sName, Chr(34), "-")
            sName = Replace(sName, "<", "-")
            sName = Replace(sName, ">", "-")
            sName = Replace(sName, "|", "-")

            dtDate = oMail.ReceivedTime
            sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
                           vbUseSystem) & Format(dtDate, "-hhnnss", _
                                                 vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

            oMail.SaveAs sPath & sName, olMsg
        End If
        DoEvents
    Next
    Set oMail = Nothing
    Set objItem = Nothing
End Sub

I have just tested the following with 3500+ messages and it worked OK - try this one first.

Public Sub TestMessageAsMsg()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
Dim i As Long: i = 0

    enviro = CStr(Environ("USERPROFILE"))
    sPath = enviro & "\Documents\MyEmails\"

    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            i = i + 1
            Set oMail = objItem

            'get name and remove special characters
            sName = Left(oMail.Subject, 100)    'limit the length of the subject
            sName = Replace(sName, "'", "-")
            sName = Replace(sName, "*", "-")
            sName = Replace(sName, "/", "-")
            sName = Replace(sName, "\", "-")
            sName = Replace(sName, ":", "-")
            sName = Replace(sName, "?", "-")
            sName = Replace(sName, Chr(34), "-")
            sName = Replace(sName, "<", "-")
            sName = Replace(sName, ">", "-")
            sName = Replace(sName, "|", "-")

            dtDate = oMail.ReceivedTime
            sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
                           vbUseSystem) & Format(dtDate, "-hhnnss", _
                                                 vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

Debug.Print sPath & sName & vbTab & i

        End If
        DoEvents
    Next
    Set oMail = Nothing
    Set objItem = Nothing
End Sub

[Adam81]

Thank you for the input, the Debug.Print helped me find the message it was stopping at. Unfortunately I don't see anything unique about that e-mail. For the time being I moved the suspect e-mail to a different location, now I am able to save 205 e-mail, but 239 e-mails are selected in outlook. The debug line registers e-mail 206, but the VBA stops there, no error message or anything unique.

On a side note, I added the oMail.SaveAs sPath & sName, olMSG line back in, just after the debug line.

Public Sub TestMessageAsMsg()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
Dim i As Long: i = 0


    enviro = CStr(Environ("USERPROFILE"))
    sPath = enviro & "\Documents\MyEmails\"


    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            i = i + 1
            Set oMail = objItem


            'get name and remove special characters
            sName = Left(oMail.Subject, 100)    'limit the length of the subject
            sName = Replace(sName, "'", "-")
            sName = Replace(sName, "*", "-")
            sName = Replace(sName, "/", "-")
            sName = Replace(sName, "\", "-")
            sName = Replace(sName, ":", "-")
            sName = Replace(sName, "?", "-")
            sName = Replace(sName, Chr(34), "-")
            sName = Replace(sName, "<", "-")
            sName = Replace(sName, ">", "-")
            sName = Replace(sName, "|", "-")


            dtDate = oMail.ReceivedTime
            sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
                           vbUseSystem) & Format(dtDate, "-hhnnss", _
                           vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
            
            Debug.Print sPath & sName & vbTab & i
            oMail.SaveAs sPath & sName, olMSG


        End If
        DoEvents
    Next
    Set oMail = Nothing
    Set objItem = Nothing
End Sub

[skatonni]

Possibly some of the selection fail the MessageClass test.

Try an else like this

Else
        
        notIPMNoteCount = notIPMNoteCount + 1
        Debug.Print " notIPMNote: " & notIPMNote

[Adam81]

skatonni, you are correct of the 239 e-mails selected 34 are not "IPM.Note". This begs the question, how do I save none "IPM.Note" Message Class'?

I tried removing the MessageClass test and I get an error message...

Thanks
Adam

[gmayor]

The following will identify the message class. Class 43 is MailItem. The various classes are listed at https://docs.microsoft.com/en-us/dot...ew=outlook-pia. As the items in question are not mail items then don't bother with setting a mailitem variable e.g.

Set oMail = objItem

as you have already identified the message as objItem. Process the objItem object directly.

Public Sub TestMessageAsMsg()
Dim objItem As Object
Dim i As Long: i = 0

    For Each objItem In ActiveExplorer.Selection
        i = i + 1
        If objItem.Class <> 43 Then
Debug.Print i & vbTab & objItem.Subject & vbTab & objItem.Class
        End If
        DoEvents
    Next
    Set objItem = Nothing
End Sub