Improve company productivity with a Business Account.Sign Up

x
?
Solved

outlook 2007 extract email addresses

Posted on 2009-04-14
5
Medium Priority
?
1,018 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 80 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 80 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

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

The article is for all the Exchange users seeking smooth and effective EDB to PST conversion. Exchange Server is the most widely used platform for messaging with collaborative sharing, Exchange online, secure working environment, etc.
This following write-up describes a different way to copy Lotus Notes Calendar to Outlook. Along with this, we will also learn the reason behind this NSF to PST migration. Users can prefer different procedures as per their convenience.
In this video I will demonstrate how to set up Nine, which I now consider the best alternative email app to Touchdown.
Watch the software video of Kernel Import PST to Office 365 tools which can easily import PST and OST files to Office 365 for bulk mailboxes. The process of migration is simple and user can map source and destination mailboxes and easily import data…

602 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