Solved

outlook 2007 extract email addresses

Posted on 2009-04-14
5
957 Views
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?
0
Comment
Question by:bingboo
  • 2
  • 2
5 Comments
 
LVL 74

Assisted Solution

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

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

JeffCoachman
0
 
LVL 65

Assisted Solution

by:rockiroads
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

'TWO WAYS TO CHECK - EITHER CHECK NAME OR ADDRESS

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

'2) EMAIL ADDY
        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

0
 

Author Comment

by:bingboo
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"

    xlsheet.Range("a2").Activate

    

    Set olApp = Outlook.Application

    Set objNS = olApp.GetNamespace("MAPI")

    Set MyFolder = objNS.PickFolder

    Call ProcessFolder(MyFolder, xlsheet)

    xlsheet.Select

    xlsheet.Range("A1").Select

    xlsheet.UsedRange.AdvancedFilter Action:=xlFilterInPlace, Unique:=True

    xlsheet.UsedRange.Select

    xlsheet.Application.Selection.Copy

    xlbook.Worksheets(2).Select

    xlsheet.Application.Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _

        True, Transpose:=False

    xlbook.Worksheets(2).Columns("A:A").Select

    xlsheet.Application.Selection.Columns.AutoFit

    xlsheet.Application.CutCopyMode = False

    xlbook.Worksheets(2).UsedRange.Select

    xlsheet.Application.Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _

        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

    xlsheet.Select

    xlsheet.ShowAllData

    xlsheet.Range("a1").Select

    xlbook.Worksheets(2).Select

    xlbook.Worksheets(2).Range("A1").Select

    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

                    Next

                End If

            End If

        End If

    Next

        

    ' 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

0
 

Accepted Solution

by:
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
0
 
LVL 74

Expert Comment

by:Jeffrey Coachman
ID: 24343962
bingboo,

;-)

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.
;-)

JeffCoachman
0

Featured Post

Why spend so long doing email signature updates?

Do you spend loads of your time carrying out email signature updates? Not very interesting are they? Don’t let signature updates get you down. Let Exclaimer Cloud - Signatures for Office 365 make managing email signatures a breeze.

Join & Write a Comment

Suggested Solutions

Outlook Free & Paid Tools
Learn to move / copy / export exchange contacts to iPhone without using any software. Also see the issues in configuration of exchange with iPhone to migrate contacts.
how to add IIS SMTP to handle application/Scanner relays into office 365.
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

760 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

19 Experts available now in Live!

Get 1:1 Help Now