I am trying, in the trivial case, to extract Outlook email bodies and paste them into a Worksheet.
However, assigning the .Body (a String) property of olMail object to the EmailBody variable (also a String) triggers an "Application-defined or object-defined error", at line EmailBody = .Body running the below code. I am using the same method seen on numerous other threads except looping through a restricted set of folder items. The olMail.Class = 43 (mailitem). Unsure why ActiveExplorer, GetInspector or the NewMailEx methods are necessary given the below code seems logical.
Why isn't this working?
CODE
Option Explicit
Sub Test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
' Part 1
Dim wb As Workbook, _
ws As Worksheet, _
tStamp1 As String, _
EmailBody As String, _
wsCount As Integer, _
j As Integer
j = 2
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
tStamp1 = Format(DateAdd("h", 10, Date - 3), "ddddd h:nn AMPM")
Dim ol As Outlook.Application, _
ns As Namespace, _
fol As MAPIFolder, _
subFolderItems As Outlook.Items, _
olMail As Object, _
olMailID As String, _
StoreID As String
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.Folders("[insert folder]").Folders("[insert folder]").Folders("[insert folder]")
Set subFolderItems = fol.Items
Set subFolderItems = subFolderItems.Restrict("[ReceivedTime] > '" & tStamp1 & "' ")
' Part 2
Do
wsCount = wb.Worksheets.Count
If wsCount > 1 Then
wb.Worksheets(2).Delete
End If
j = j + 1
Loop Until wsCount = 1
For Each olMail In subFolderItems
With olMail
If .Subject Like "*[insert subject]*" Then
.BodyFormat = olFormatPlain
EmailBody = .Body
With wb
.Worksheets.Add After:=.Worksheets(1)
.Worksheets(2).Range("A1").Value = EmailBody
End With
ElseIf .Subject = "[insert subject]" Then
.Display
End If
End With
Next olMail
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
EDIT #1
Substituted
olMailID = .EntryID
StoreID = fol.StoreID
Set olMail = ns.GetItemFromID(olMailID)
For
.BodyFormat = olFormatPlain
and the error now reverts to "Application-defined or object-defined error".
EDIT #2
Noticed in Locals window that the body carries no value
EDIT #3
So, tried MS suggestions found here but received the same error at line Set wdDoc = myInspector.WordEditor; which lead to here, implying an Outlook security feature is preventing the extraction. Not fully confident this is the cause but does anybody have a better idea?
Option Explicit
Sub Test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
' Part 1
Dim wb As Workbook, _
ws As Worksheet, _
tStamp1 As String, _
EmailBody As String, _
wsCount As Integer, _
j As Integer
j = 2
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
tStamp1 = Format(DateAdd("h", 10, Date - 3), "ddddd h:nn AMPM")
Dim ol As Outlook.Application, _
ns As Namespace, _
fol As MAPIFolder, _
subFolderItems As Outlook.Items, _
olMail As Object, _
olMailID As String, _
StoreID As String
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.Folders("[insert folder]").Folders("[insert folder]").Folders("[insert folder]")
Set subFolderItems = fol.Items
Set subFolderItems = subFolderItems.Restrict("[ReceivedTime] > '" & tStamp1 & "' ")
Dim myInspector As Outlook.Inspector, _
wdDoc As Word.Document, _
wdRange As Word.Range
' Part 2
Do
wsCount = wb.Worksheets.Count
If wsCount > 1 Then
wb.Worksheets(2).Delete
End If
j = j + 1
Loop Until wsCount = 1
For Each olMail In subFolderItems
With olMail
If .Subject Like "*[insert subject]*" Then
.Display
Set myInspector = .GetInspector
Set wdDoc = myInspector.WordEditor
Set wdRange = wdDoc.Range(0, wdDoc.Characters.Count)
wdRange.InsertBefore ("EMAIL BODY")
End If
End With
Next olMail
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
EDIT #4
Here is the same approach as first described. I have copied it exactly and still find the same error at same place, so this must be security or Outlook upgrade related.
EDIT #5
So, after rethinking through the problem, have tried navigating around the plausible security issue by running the below code in Outlook. Yet, the same error appears at line .SaveAs (Str), olTXT (enumeration and syntax seem fine).
Option Explicit
Sub Test()
Dim ol As Application, _
ns As Namespace, _
fol As MAPIFolder, _
subFolderItems As Items, _
olMail As Object, _
Str As String, _
tStamp1 As String
tStamp1 = Format(DateAdd("h", 10, Date - 1), "ddddd h:nn AMPM")
Set ol = New Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.Folders("[insert folder]").Folders("[insert folder]").Folders("[insert folder]")
Set subFolderItems = fol.Items
Set subFolderItems = subFolderItems.Restrict("[ReceivedTime] > '" & tStamp1 & "' ")
For Each olMail In subFolderItems
With olMail
If .Subject Like "*[insert subject]*" Then
Str = "[insert file path]"
Str = Str & .Subject & ".txt"
.SaveAs (Str), olTXT
End If
End With
Next olMail
End Sub
EDIT #6
Looked here which lead to here where this section
is important. No Admin rights so avenue of enquiry is moot.
