outlook 2007 extract email addresses

I have created and tried a couple of different macros I saw some users at EE suggest, but i have not had any success.  We have an old mailing list that needs to be updated I would like to extract the email addresses from all of our undeliverables.

all emails are from: System Administrator
and I would like to recover the "To" field.

Any ideas?
Who is Participating?
bingbooConnect With a Mentor Author Commented:
Anyone that needs this done --- this worked flawlessly and a very simple solution:
In Outlook 2007, click on File, Import and Export and the Wizard opens up.
Select the option to Export to a File and click on Next
Select Microsoft Excel 97-2003 (or a CSV file) and click on Next
Select the folder that your sales inquiries reside in and click on Next
Click on Browse to select a location and then type the file name that you want to export the information to and then click on Next
Here is the important bit - click on Map Custom Fields. This will bring up a list of all the available fields that are available in that folder.
Since we are only interested in Email address, click on Clear Map and then from the Left side click on From: (address) and drag that to the Right list
Click on OK
Click on Finish
Jeffrey CoachmanConnect With a Mentor MIS LiasonCommented:

I will presume that:
1. This is a table
2. "System Administrator" is a Field in that table
3. This is a one shot deal

Run this query to update the "To" field with the values from the "System Administrator" field.
  UPDATE YourTable SET YourTable.[To] = [System Administrator]

Run this query if you want to delete the values from the System Administrator" field, after they are copied to the "To" field.
  UPDATE YourTable SET YourTable.[System Administrator] = "" 
  WHERE YourTable.[System Administrator] Is Not Null

rockiroadsConnect With a Mentor Commented:
You could try iterate thru items (tested on outlook 2003, would assume it still works on outlook 2007)

    Dim olApp As Object
    Dim olFolder As Object
    Dim i As Integer
    Set olApp = CreateObject("Outlook.Application")
    Set olFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(6)
    For i = 1 To olFolder.items.count


'1) NAME
        If InStr(1, LCase$(olFolder.items(i).SenderName), "System Administrator") > 0 Then

        If InStr(1, LCase$(olFolder.items(i).SenderEmailAddress), "aa@bb") > 0 Then

            'Dump the to address
            Debug.Print olFolder.items(i).To
        End If
    Next i
    Set olFolder = Nothing
    Set olApp = Nothing

bingbooAuthor Commented:
The emails are currently in a subfolder under the inbox.  The script I have so far allows me to launch and then specify directory location, it then open excels but it is empty (from what I read it is confirmed success on 2003).

Option Explicit
Sub launchpad()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim MyFolder As Outlook.MAPIFolder
Dim xlApp As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
    On Error Resume Next
    Set xlApp = CreateObject("Excel.Application")
    Set xlbook = xlApp.Workbooks.Add
    Set xlsheet = xlbook.Worksheets(1)
    xlsheet.Range("A1") = "email Address"
'    xlsheet.Range("B1") = "Sender Name"
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set MyFolder = objNS.PickFolder
    Call ProcessFolder(MyFolder, xlsheet)
    xlsheet.UsedRange.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    xlsheet.Application.Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        True, Transpose:=False
    xlsheet.Application.CutCopyMode = False
    xlsheet.Application.Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    xlApp.Visible = True
    Set objNS = Nothing
Set MyFolder = Nothing
Set xlsheet = Nothing
Set xlbook = Nothing
Set xlApp = Nothing
End Sub
Function fnEmailVal(mailAddress As String) As Boolean
' Uses "Microsoft VBScript Regular Expressions" Type Library
Dim regEx As RegExp
    Set regEx = New RegExp
    regEx.Pattern = "^\w+([\.-]?\w+)*@\w+([\.-]?\w+)*(\.\w{2,3})+$"
    fnEmailVal = regEx.Test(mailAddress) = True
Set regEx = Nothing
End Function
Sub ProcessFolder(startFolder As MAPIFolder, dataRecord As Excel.Worksheet)
Dim objFolder As Outlook.MAPIFolder
Dim objitem As Object
Dim mai As MailItem
Dim rejects() As String
Dim addy_count As Integer
Dim strBody As String
Dim emailInvest As String
    On Error Resume Next
    MsgBox startFolder.Path, , "testing"
    ' process all the items in this folder
    For Each objitem In startFolder.Items
        If TypeName(objitem) = "MailItem" Then
            Set mai = objitem
            If mai.BodyFormat = olFormatHTML Then
            ElseIf mai.BodyFormat = olFormatPlain Or mai.BodyFormat = olFormatRichText Then
                mai.Body = Replace(mai.Body, "<", " ")
                mai.Body = Replace(mai.Body, ">", " ")
                mai.Body = Replace(mai.Body, "[", " ")
                mai.Body = Replace(mai.Body, "]", " ")
                mai.Body = Replace(mai.Body, "mailto:", " ")
                mai.Body = Replace(mai.Body, "/t", " ")
                mai.Body = Replace(mai.Body, Chr(10), " ")
                mai.Body = Replace(mai.Body, Chr(13), " ")
                mai.Body = Replace(mai.Body, vbCrLf, " ")
                rejects = Split(mai.Body & "@", "@")
                If UBound(rejects) > 1 Then
                    For addy_count = 1 To UBound(rejects) - 1
                        emailInvest = Right(rejects(addy_count), Len(rejects(addy_count)) - InStrRev(rejects(addy_count), " ")) & "@"
                        emailInvest = Trim(emailInvest & Left(rejects(addy_count + 1), InStr(rejects(addy_count + 1), " ")))
                        If fnEmailVal(emailInvest) Then
                        'Debug.Print emailInvest
                            dataRecord.Application.ActiveCell.Offset(0, 0) = emailInvest
                            dataRecord.Application.ActiveCell.Offset(1, 0).Activate
                        End If
                End If
            End If
        End If
    ' process all the subfolders of this folder
'    For Each objFolder In startFolder.Folders
'        Call ProcessFolder(objFolder, dataRecord)
'    Next
Set mai = Nothing
Set objFolder = Nothing
End Sub

Open in new window

Jeffrey CoachmanMIS LiasonCommented:


Well it was not clear that you simply wanted this.
You never clarified any of the presumptions in my original post.

Please remember that you did not state if this was an Outlook table or an externally generated table.

But, in any event, I am glad you got the issue resolved.

All Courses

From novice to tech pro — start learning today.