compile a list of email addresses

[stuck]

Posting this in Office General as I'm not sure of the best way to achieve what I want.

I have a folder (on our network) containing about 100 email messages in Outlook .msg format. They are all 'undeliverable' bounces. I want to be able to open each one in turn, extract the bad email address from the body of the message and store it in a list. Can something like this be done?

Or would It be quicker for me to just do it manually?

Ken

[HansV]

Sometimes an 'undeliverable' message contains more than one e-mail address. Is there an easy way to determine the one you want, e.g. is there a fixed text before or after it?

[stuck]

Sometimes an 'undeliverable' message contains more than one e-mail address.

Ah yes, it will also contain references to where it came from. I'll have a look to see if there is some sort of common / fixed text that would act as a tag for the particular address I'm interested in but a 'quick and dirty' extract all email address might be all I need.

Ken

[HansV]

It'd also be useful to know if there is a space before and after the e-mail address, or that there could be punctuation, a line break or something else.

[stuck]

It seems the body text has the following structure:

Code: Select all

Delivery has failed to these recipients or groups:

someone@mydomain.com
The e-mail address you entered couldn't be found...

i.e. there appears to be a blank line before the address and std text on the following line.

Ken

[Leif]

Interesting. That is different text and layout to what we get from our service provider, and I wonder if it depends on the software they use (as opposed to the rejecting service provider).

Code: Select all

This message was created automatically by mail delivery software.

A message that you sent could not be delivered to one or more of its
recipients. This is a permanent error. The following address(es) failed:

  recipient1@company.com
    SMTP error from remote mail server after RCPT TO:<recipient1@company.com>:
    host mail2.company.com [78.46.34.nnn]:
    550 5.1.1 <recipient1@company.com>: Recipient address rejected:
    undeliverable address: Unknown user
  recipient2@company.com
    SMTP error from remote mail server after RCPT TO:<recipient2@company.com>:
    host mail2.company.com [78.46.34.nnn]:
    550 5.1.1 <recipient2@company.com>: Recipient address rejected:
    undeliverable address: Unknown user

------ This is a copy of the message, including all the headers. ------

Note that where there are multiple recipients, there is no blank line before the second failed recipient.

[stuck]

My understanding is that the bounce message I see is something generated by our Exchange server from what ever arrives from the mail system rejecting the message.

Of course I might be completely wrong!

Ken

[Leif]

Should be easy to check the header from a sample - the above is from an email sent from "Mail Delivery System <Mailer-Daemon@seattle.footholds.net>" (seattle.footholds.net being where our domain is).

[HansV]

The following should work for the layout that you describe, but it'll fail for the layout that Leif mentioned. It may list the same e-mail address twice though.
This code should be run from within Outlook. Change the constant at the beginning before running the macro.

Code: Select all

Sub ExtractAllAddresses()
    ' Path including trailing backslash
    'Const strPath = "C:\Bounced\"
    ' File name of output text file
    Const strOutput = "List.txt"
    Dim strFile As String
    Dim nsp As NameSpace
    Dim itm As MailItem
    Dim strBody As String
    Dim lngPos1 As Long
    Dim lngPos2 As Long
    Dim lngPos3 As Long
    Dim strAddress As String
    Dim f As Long
    ' Create output file
    f = FreeFile
    Open strPath & strOutput For Output As #f
    ' Get name space
    Set nsp = GetNamespace("MAPI")
    ' Loop through .msg files
    strFile = Dir(strPath & "*.msg")
    Do While strFile <> ""
        ' Open file in Outlook
        Set itm = nsp.OpenSharedItem(strPath & strFile)
        ' Get body text
        strBody = itm.Body
        ' Find position of @
        lngPos1 = InStr(strBody, "@")
        Do While lngPos1 > 0
            ' Find start of address
            lngPos2 = lngPos1 - 1
            Do While Asc(Mid(strBody, lngPos2, 1)) > 35
                lngPos2 = lngPos2 - 1
                If lngPos2 = 1 Then Exit Do
            Loop
            ' Find end of address
            lngPos3 = lngPos1 + 1
            Do While Asc(Mid(strBody, lngPos3, 1)) > 35
                lngPos3 = lngPos3 + 1
                If lngPos3 = Len(strBody) Then Exit Do
            Loop
            ' Extract e-mail address
            strAddress = Mid(strBody, lngPos2 + 1, lngPos3 - lngPos2 - 1)
            ' Write address to output file
            Print #f, strAddress
            lngPos1 = InStr(lngPos3 + 1, strBody, "@")
        Loop
        ' Close item
        itm.Close olDiscard
        ' On to the next file
        strFile = Dir
    Loop
    ' Close output file
    Close #f
End Sub

The output will be a text file named List.txt in the same folder.

[stuck]

Set the Const strPath = to the relevant path

but first attempt stops with type mismatch at:
Set itm = nsp.OpenSharedItem(strPath & strFile)

Ken

[HansV]

That would indicate that the file is not an e-mail item but something else...

[stuck]

OK but when I hover over 'strPath' I see the path I set and over strFile I see the name of the first file in the folder. That file has a .msg extension and when I double click it it opens in Outlook and appears to be a genuine email message.

Is it because I'm using Outlook 2007?

Ken

[HansV]

The code should work in any version of Outlook (as far as I can tell, it doesn't use anything introduced in Outlook 2010 or later).
You might try declaring itm as a Variant instead of as a MailItem:

Code: Select all

    Dim itm As Variant

but I fear that the code will then fail on the next line. Still, it's worth a try.

[stuck]

No, didn't fail. I have a list of email addresses!

Magic

There is a Santa Claus!

Many thanks,

Ken