Solved

outlook 2007 extract email addresses

Posted on 2009-04-14
5
967 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

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