I NEED A LIST OF ALL EMAIL ADDRESSES I'VE CONTACTED ON OUTLOOK2010

I need to create a master list for email marketing purposes and there are hundreds of email addresses i've emails, but haven't saved as a contact.

Can I please be told a way to gather a report or list showing me all email addresses that have ever been sent to or even received from....thanks.

Please I need help!

July 16th, 2013 11:04am

The following code sample will generate a .csv file with a list of email addresses of the Senders of the emails in the Inbox folder:

  • Copy and paste it into the ThisOutlookSession of the Outlook VBA Editor, and run it;
  • The output file will be saved at C:\Test\emails.csv, modify the path in the code as you desired;
  • Modify the value of .GetDefaultFolder(olFolderInbox) in the following code line to select the other folder other than Inbox;
    Set objFolder = Application.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Sub GetALLEmailAddresses_Resolve_Name()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
Dim objDic As Object
Dim objItem As Object
Dim objFSO As Object
Dim objTF As Object
Dim sFromName As String

Set objDic = CreateObject("scripting.dictionary")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile("C:\Test\emails.csv", 2)
Set objFolder = Application.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)

For Each objItem In objFolder.Items


    If objItem.Class = olMail Then
    
        sFromName = objItem.SenderName
        strEmail = ResolveDisplayNameToSMTP(sFromName)

        If strEmail = Empty Then
        
            strEmail = objItem.SenderEmailAddress
            
                        If Not objDic.Exists(strEmail) Then
                objTF.writeline strEmail
                objDic.Add strEmail, ""
            End If
            
        Else
                    If Not objDic.Exists(strEmail) Then
                objTF.writeline strEmail
                objDic.Add strEmail, ""
            End If
            
        End If
        

        

    End If
Next

objTF.Close

End Sub

Function ResolveDisplayNameToSMTP(sFromName)
 Dim oRecip As Outlook.Recipient
 Dim oEU As Outlook.ExchangeUser
 Dim oEDL As Outlook.ExchangeDistributionList
 
 Set oRecip = Application.Session.CreateRecipient(sFromName)
 oRecip.Resolve
 If oRecip.Resolved Then
 Select Case oRecip.AddressEntry.AddressEntryUserType
 Case OlAddressEntryUserType.olExchangeUserAddressEntry
 Set oEU = oRecip.AddressEntry.GetExchangeUser
 If Not (oEU Is Nothing) Then
 Debug.Print oEU.PrimarySmtpAddress
 End If
 Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
 Set oEDL = oRecip.AddressEntry.GetExchangeDistributionList
 If Not (oEDL Is Nothing) Then
 Debug.Print oEDL.PrimarySmtpAddress
 End If
 End Select
 End If

 End Function
Free Windows Admin Tool Kit Click here and download it now
July 17th, 2013 6:02am

This topic is archived. No further replies will be accepted.

Other recent topics Other recent topics