Hi
I'm not an expert in VBA, so this may be something obvious and I've missed it. About a month ago, I wrote a VBA program in an Excel 2013 workbook to go to a specified folder in my Outlook (the Inbox for one of my accounts) and search through all emails from a given date to look for any returned emails and, for those emails, to extract the email addresses contained in the text of the undelivered email. I put it together from code I found on the net, and eventually got it working fine. The first pass searched for emails with "undeliverable" in the Subject and, for those emails, it then searched the Body of the text for emails and extracted them to the excel workbook. It now doesn't work. The initial selection of emails with "undeliverable" in the Subject line works, but somehow the characters on the .Body of the ReportItem (I've found out it's not a MailItem, as its returned mail) don't appear to copy to my string correctly, and, when I use the .Display function to show the email, the header and subject line are fine, but the text of the email appears to be Chinese characters. However, when I look at that email (and the other returned emails) using Outlook 2013, the text in the body is perfectly readable. Similarly using MsgBox to display the string into which I've copied the body of the email just shows lines of ????? . As a result, although is does find undelivered emails, it doesn't find any email addresses in the bodies of these emails
Extracts from my code are below. I appreciate any thoughts anyone has.
Thanks
G_in_Sydney
Dim MyOutLookApp As Object
Dim MyNameSpace As Object
Dim MyFolder As Object
Dim i, j, Index, index1, p, l, m, n As Integer
Dim itms, filteredItms As Outlook.Items
Dim MyDate As Variant
Dim olMail As Object
Dim EmailBody As String
Dim Check1 As Variant
Dim Start, EndofTexttoSearch, EmailAddressCounter, UndeliveredEmailAddresses As Integer
Dim TextatendofSearch As String
etc involving the workbook
etc
Set MyOutLookApp = CreateObject("Outlook.Application")
On Error GoTo ErrFlder
If MyOutLookApp Is Nothing Then
MsgBox "Please open Outlook first,then try again."
Exit Sub
End If
'
' Set MyNameSpace to contain all the email account folder names in Outlook
'
Set MyNameSpace = MyOutLookApp.GetNamespace("MAPI")
'
' Set MyFolder to folder number(15), then to the Inbox number (2)
Set MyFolder = MyNameSpace.Folders(15).Folders(2)
'
' Set itms to be the collection of all Outlook items within MyFolder
Set itms = MyFolder.Items
' Set filteredItms to filter items in MyFolder to on or after the date set above
Set filteredItms = itms.Restrict("[ReceivedTime]> '" & Format(MyDate, "ddddd h:nn AMPM") & "'")
MsgBox "filteredItms = " & filteredItms.Count ' I use to check it is selecting only after the set date
EmailAddressCounter = 1
UndeliveredEmailAddresses = 0
For Each olMail In filteredItms
If InStr(olMail.Subject, "Undeliverable") <> 0 Then
EmailBody = olMail.Body
Msgbox EmailBody ' Displays as lines of ???????
MsgBox Len(EmailBody) ' Displays positive numbers, typically around 2000 characters
olMail.Display ' Shows the body as Chinese characters, although the header of the email is fine
Start = 1
etc etc to search through the text for email addresses
'
