I collect all my undeliverable sent Emails in an (Outlook) Inbox
folder named "Undeliverables".
I 'd like to open them one by one and list the addresses up on an
Excel sheet.
My VBA knowledge will do for the Excel part but not for the Outlook
part.
Can you help me? Maybe there is already a posting on this subject but
I couldn't find it.
Thank you very much.

Below is the code tha tI used with outlook. If you are using the find
feature in outlook you will need to use a class module as well as a regular
module. Hre is mboth sets of code. I wanted to filter the emails base on
the data. I also want to retrieve the body of the email which is an html
file. I had to put the data into a temporary file to get the body of the
email message.

Ron DeBruin has some tips on his webpage
http://www.rondebruin.nl/tips.htm

-----------------------------------------------------------
class module
Public WithEvents olApp As Outlook.Application
Private m_sch As Outlook.Search
Public Sub AdvSearch(MyScope As String, MyFilter As String, _
ByRef m_sch)
Set m_sch = olApp.AdvancedSearch(MyScope, MyFilter)
End Sub
Private Sub Class_Initialize()
Set Me.olApp = CreateObject("Outlook.Application")
Set myNamespace = Me.olApp.GetNamespace("MAPI")
Set myfolder = myNamespace.GetDefaultFolder(olFolderInbox)
End Sub
Private Sub Class_Terminate()
Set Me.olApp = Nothing
End Sub
Private Sub olApp_AdvancedSearchComplete(ByVal SearchObject As Outlook.Search)
blnSearchComp = True
End Sub


----------------------------------------------------------------------------------------

regular module

Public blnSearchComp As Boolean
Public g_clsTest As Class1
Sub GetMail()

Const strS As String = "Inbox"
Dim strF As String
Dim sch As Outlook.Search
Dim rsts As Outlook.Results
Const ForReading = 1, ForWriting = 2, _
ForAppending = 3
Dim TBL As Object

TempPath = Environ("Temp")
FName = TempPath & "\OutlookTMP.HTML"


strF = "urn:schemas:httpmail:" & _
"subject LIKE '%Lock%' AND" & _
"%today(urn:schemas:httpmail:datereceived)%"


blnSearchComp = False
Set g_clsTest = New Class1
g_clsTest.AdvSearch strS, strF, sch


While blnSearchComp = False
DoEvents
Wend

Set rsts = sch.Results
If rsts.Count = 0 Then
MsgBox ("No messages found - Exiting Sub")
Exit Sub
End If
rsts.Sort "ReceivedTime", Descending:=True
Set LatestMess = rsts.Item(1)


Set fs = CreateObject("Scripting.FileSystemObject")
Set fout = fs.CreateTextFile _
(FName, True)
fout.Write LatestMess.HTMLBody
fout.Close

'desroy class object
Set g_clsTest = Nothing

'Set IEObj = GetObject(FName)
Set IE = CreateObject("INternetExplorer.Application")
IE.Application.Visible = True
URL = FName
IE.Navigate2 URL
Do While IE.readyState < 4
DoEvents
Loop

Set TBL = IE.document.getelementsbytagname("Table")

'find Net and Gross
'Set statement below causes errors

Set TBLRows = TBL.Item(0).Rows


Set RowOne = TBLRows.Item(0)
Set RowTwo = TBLRows.Item(1)
For i = 0 To (RowOne.Children.Length - 1)
If UCase(RowOne.Children.Item(i).innertext) = "NET" Then
NetCol = i
End If
If UCase(RowOne.Children.Item(i).innertext) = "GROSS" Then
GrossCol = i
End If

Next i
Net = Val(RowTwo.Children.Item(NetCol).innertext)
Gross = Val(RowTwo.Children.Item(GrossCol).innertext)
Total = Net + Gross
ActiveCell.Value = Total

IE.Application.Quit
End Sub



" wrote:

I collect all my undeliverable sent Emails in an (Outlook) Inbox
folder named "Undeliverables".
I 'd like to open them one by one and list the addresses up on an
Excel sheet.
My VBA knowledge will do for the Excel part but not for the Outlook
part.
Can you help me? Maybe there is already a posting on this subject but
I couldn't find it.
Thank you very much.

See if what I've got between the lines gives you a start. In this case, the
routine looks at the body of each message in the Inbox subfolder named
"undeliverables" and if a line containing the @ symbol is found, the line
comes up in a message box. I'm assuming you will be listing such lines on a
worksheet instead but you said you could handle the Excel portion.

'------------------------------------

Sub CheckUndeliverables()

Const olFolderInbox = 6

Dim strBody As String

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Folders("Undeliverables")

Set colItems = objFolder.Items

For Each objItem In colItems
strBody = objItem.Body
arrLines = Split(strBody, vbCrLf)
For x = 0 To UBound(arrLines)
If InStr(arrLines(x), "@") 0 Then
MsgBox arrLines(x)
End If
Next x
Next objItem

Set objFolder = Nothing
Set objInbox = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing
End Sub


'------------------------------------

Steve Yandl



wrote in message
...
I collect all my undeliverable sent Emails in an (Outlook) Inbox
folder named "Undeliverables".
I 'd like to open them one by one and list the addresses up on an
Excel sheet.
My VBA knowledge will do for the Excel part but not for the Outlook
part.
Can you help me? Maybe there is already a posting on this subject but
I couldn't find it.
Thank you very much.