outlook 2007 extract email addresses

Posted on 2009-04-14
Last Modified: 2013-11-27
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?
Question by:bingboo
  • 2
  • 2
LVL 74

Assisted Solution

by:Jeffrey Coachman
Jeffrey Coachman earned 20 total points
ID: 24142560

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

LVL 65

Assisted Solution

rockiroads earned 20 total points
ID: 24145303
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


Author Comment

ID: 24147902
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


Accepted Solution

bingboo earned 0 total points
ID: 24296422
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
LVL 74

Expert Comment

by:Jeffrey Coachman
ID: 24343962


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.


Featured Post

Zoho SalesIQ

Hassle-free live chat software re-imagined for business growth. 2 users, always free.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Utilizing an array to gracefully append to a list of EmailAddresses
Large Outlook files lead to various unwanted errors and corruption issues. Furthermore, large outlook files can also make Outlook take longer to start-up, search, navigate, and shut-down. So, In this article, i will discuss a method to make your Out…
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
This video discusses moving either the default database or any database to a new volume.

910 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now