Outlook scan body message for email

Category:

Office/VBA

Type:

Applications

Difficulty:

Advanced

Author:

Anonymous

Version Compatibility:

More information:

This code will scan through any folder in your Mailbox and return any emails mentionned in the body of the messages. I wrote this code because I am doing some mass emailing to a community and I needed to collect the emails of all the delivery failure messages to remove them from my listing.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
' (None)

Code:

Sub listemail()

Dim onMAPI As NameSpace
Dim oicNewMail As Items
Dim oicInbox As MAPIFolder  ' MAPIFolder object to specify inbox.
Dim oicCountryside As MAPIFolder    ' MAPIFolder object to specify countryside folder.
Dim oiMail As MailItem
Dim iFor As Integer
Set onMAPI = Application.GetNamespace("MAPI")
Set oicInbox = onMAPI.GetDefaultFolder(olFolderInbox)
Set oicCountryside = oicInbox.Folders("1 Filter Bulk ")
Set oicNewMail = oicCountryside.Items
'change emailtoremove.txt to whatever you want the output file to be
Open "C:\emailtoremove.txt" For Output As #1
    For iFor = oicNewMail.Count To 1 Step -1
    'For iFor = 1 To 8
        'If oicNewMail.Item(iFor).UnRead And oicNewMail.Item(iFor).Class = olMail Then
            Set oiMail = oicNewMail.Item(iFor)
            'Print #1, oiMail.Body;
            emailstart = 0
            atposition = 0
            For i = 1 To Len(oiMail.Body)
            'If atposition <> 0 And Right(Left(oiMail.Body, i), 1) = " " Then
            '    MsgBox Right(Left(oiMail.Body, i), emailstart)
            '    atposition = 0
            'End If
            '
            'If Right(Left(oiMail.Body, i), 1) = " " Or Right(Left(oiMail.Body, i), 1) = Chr(10) Then emailstart = i
            If Right(Left(oiMail.Body, i), 1) = "@" Then
            atposition = i
            j = 1
            While Right(Left(oiMail.Body, i + j), 1) <> " " And Right(Left(oiMail.Body, i + j), 1) <> Chr(10) And Right(Left(oiMail.Body, i + j), 1) <> ">" And Right(Left(oiMail.Body, i + j), 1) <> Chr(13)
            j = j + 1
            Wend
            k = 1
            While Right(Left(oiMail.Body, i - k), 1) <> " " And Right(Left(oiMail.Body, i - k), 1) <> Chr(10) And Right(Left(oiMail.Body, i - k), 1) <> "<" And Right(Left(oiMail.Body, i - k), 1) <> Chr(13)
            k = k + 1
            Wend
            emailstart = i - k
            Emailend = i + j - 1
            Print #1, Right(Left(oiMail.Body, Emailend), Emailend - emailstart);
            Print #1, Tab(1)
            End If
            Next i
            
            'oiMail.Delete
        'End If
    Next
Close #1

End Sub