Harvesting All Email Addresses From an Outlook Mailbox


Let’s face it, I like answering questions. I’m active on both Experts-Exchange and Quora, and have started monitoring Twitter looking for questions I can answer. Earlier this year I discovered Replyz, a novel web service that scans Twitter for questions. Replyz is where I ran across this question from marthasmith.

Does anyone have a magical way to extract all email addresses out of my Outlook? Not just contacts–out of messages, everything.

Harvesting addresses is pretty simple. I showed how to do this for meetings in this earlier post. marthasmith wants to take it a step further and collect address for different Outlook items types (e.g. emails, addresses, contacts, etc.) and she wants to do this for all folders. The first requirement calls for detecting the item type being processed since different types of items have different properties. The second requirement can be satisfied through a recursive loop.

Here is the code for doing this. This solution starts at the currently selected folder and processes it and all folders under it. This gives marthasmith the ability to control where harvesting begins. The code reads all the items in the top level folder, then does the same for every folder under it. Only certain types of items are processed. Notes don’t have addresses associated with them so there’s nothing to do with them. A task could have an address associated with it if the task was assigned, but in my experience that’s a rarely used feature of Outlook tasks. Right now the code ignores tasks. That leaves messages, appointments, contacts, and distribution lists. The code handles all for of those types of items.

In a follow-up tweet marthasmith noted that she wants the addresses put into a database. Without details on what type of database I couldn’t add that to the code. So for the moment the code extracts addresses to a text file.

Here are the instructions marthasmith will follow to add the code to Outlook.

  1. Start Outlook
  2. Click Tools > Macro > Visual Basic Editor
  3. If not already expanded, expand Microsoft Office Outlook Objects
  4. If not already expanded, expand Modules
  5. Select an existing module (e.g. Module1) by double-clicking on it or create a new module by right-clicking Modules and selecting Insert > Module.
  6. Copy the code from the Code Snippet box and paste it into the right-hand pane of Outlook’s VB Editor window
  7. Edit the code as needed. I included comments wherever something needs to or can change
  8. Click the diskette icon on the toolbar to save the changes
  9. Close the VB Editor
Dim objFSO As Object, objFile As Object

Sub HarvestAddresses()
    InitDatabase
    ProcessFolder Application.ActiveExplorer.CurrentFolder
    CloseDatabase
    MsgBox "Done"
End Sub

Sub ProcessFolder(olkFld As Outlook.Folder)
    Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.Recipient, intIdx As Integer
    For Each olkItm In olkFld.Items
        DoEvents
        Select Case olkItm.Class
            Case olMail, olAppointment
                WriteToDatabase olkItm.SenderEmailAddress
                For Each olkRcp In olkItm.Recipients
                    WriteToDatabase olkRcp.AddressEntry.Address
                Next
            Case olContact
                If olkItm.Email1Address <> "" Then WriteToDatabase olkItm.Email1Address
                If olkItm.Email2Address <> "" Then WriteToDatabase olkItm.Email2Address
                If olkItm.Email3Address <> "" Then WriteToDatabase olkItm.Email3Address
            Case olDistList
                For intIdx = 1 To olkItm.MemberCount
                    WriteToDatabase olkItm.GetMember(intIdx).AddressEntry.Address
                Next
        End Select
    Next
    For Each olkSubFld In olkFld.Folders
        ProcessFolder olkSubFld
        DoEvents
    Next
    Set olkItm = Nothing
    Set olkSubFld = Nothing
    Set olkRcp = Nothing
End Sub

Sub InitDatabase()
    Const ForWriting = 2
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Edit the file name and path on the next line
    Set objFile = objFSO.CreateTextFile("C:\eeTesting\Address Harvest.txt", ForWriting, True)
End Sub

Sub WriteToDatabase(strAddress As String)
    objFile.WriteLine strAddress
End Sub

Sub CloseDatabase()
    objFile.Close
    Set objFile = Nothing
    Set objFSO = Nothing
End Sub

When marthasmith is ready to harvest addresses she will

  1. Select a starting folder.
  2. Run the macro HarvestAddresses

A dialog-box will inform her when the code is finished. She’ll then open the output file where she will find all the addresses.

Notes.

  • The code does not currently eliminate duplicates. Addresses are likely to occur multiple times.
  • Addresses are not sorted. This could be solved by importing the data into Excel and sorting.
Advertisements

90 comments on “Harvesting All Email Addresses From an Outlook Mailbox

  1. Hi David
    Could you change the below macro referring to David Lee April 4, 2017 @ 10:17 pm so the below macro also contains the SenderName (if any)?
    BR Søren

    Const OUTPUT_FILE_PATH = "C:\user\OutlookSaveTest\Address Harvest.csv"
    Dim objDic As Object
       
    Sub HarvestAddresses()
        Dim olkSto As Outlook.Store
        Set objDic = CreateObject("Scripting.Dictionary")
        For Each olkSto In Session.Stores
            ProcessFolder olkSto.GetRootFolder
        Next
        WriteListToFile
        Set olkSto = Nothing
        Set objDic = Nothing
        MsgBox "Done"
    End Sub
    
    
    Sub ProcessFolder(olkFld As Outlook.Folder)
        Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.Recipient, intIdx As Integer, arrAdr As Variant, varAdr As Variant
        On Error Resume Next
        For Each olkItm In olkFld.Items
            DoEvents
            Select Case olkItm.Class
                Case olAppointment
                    AddToList GetSender(olkItm)
                    For Each olkRcp In olkItm.Recipients
                        Select Case olkRcp.AddressEntry.AddressEntryUserType
                            Case olExchangeUserAddressEntry
                                AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress
                            Case olExchangeDistributionListAddressEntry
                                AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress
                            Case Else
                                AddToList olkRcp.AddressEntry.Address
                        End Select
                    Next
                    arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                    For Each varAdr In arrAdr
                        AddToList varAdr
                    Next
                Case olMail
                    If TypeName(olkItm.Sender)  "Nothing" Then
                        If olkItm.Sender.AddressEntryUserType = olExchangeUserAddressEntry Then
                            AddToList olkItm.Sender.GetExchangeUser.PrimarySmtpAddress
                        Else
                            AddToList olkItm.SenderEmailAddress
                        End If
                    Else
                        If olkItm.SenderEmailAddress  "" Then
                            AddToList olkItm.SenderEmailAddress
                        End If
                    End If
                    For Each olkRcp In olkItm.Recipients
                        Select Case olkRcp.AddressEntry.AddressEntryUserType
                            Case olExchangeUserAddressEntry
                                AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress
                            Case olExchangeDistributionListAddressEntry
                                AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress
                            Case Else
                                AddToList olkRcp.AddressEntry.Address
                        End Select
                    Next
                    arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                    For Each varAdr In arrAdr
                        AddToList varAdr
                    Next
                Case olContact
                    If olkItm.Email1Address  "" Then AddToList olkItm.Email1Address
                    If olkItm.Email2Address  "" Then AddToList olkItm.Email2Address
                    If olkItm.Email3Address  "" Then AddToList olkItm.Email3Address
                Case olDistList
                    For intIdx = 1 To olkItm.MemberCount
                        AddToList olkItm.GetMember(intIdx).AddressEntry.Address
                    Next
            End Select
        Next
        On Error GoTo 0
        For Each olkSubFld In olkFld.Folders
            ProcessFolder olkSubFld
            DoEvents
        Next
        Set olkItm = Nothing
        Set olkSubFld = Nothing
        Set olkRcp = Nothing
    End Sub
    
    Sub AddToList(varAdr As Variant)
        Dim varTmp As Variant
        varTmp = VBA.LCase(varAdr)
        If Not objDic.Exists(varTmp) Then
            objDic.Add VBA.LCase(varTmp), VBA.LCase(varTmp)
        End If
    End Sub
    
    Sub WriteListToFile()
        Const ForWriting = 2
        Dim objFSO As Object, objFile As Object, arrVal As Variant, varVal As Variant
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objFile = objFSO.CreateTextFile(OUTPUT_FILE_PATH, ForWriting, True)
        arrVal = objDic.Items
        For Each varVal In arrVal
            objFile.WriteLine varVal
        Next
        objFile.Close
        Set objFile = Nothing
        Set objFSO = Nothing
    End Sub
      
    Private Function FindString(strText As String, strFind As String) As String
        Dim objRegEx As Object, colMatches As Object, objMatch As Object
        Set objRegEx = CreateObject("VBscript.RegExp")
        With objRegEx
            .IgnoreCase = True
            .Global = True
            .Pattern = strFind
            Set colMatches = .Execute(strText)
        End With
        For Each objMatch In colMatches
            FindString = FindString &amp; objMatch.Value &amp; "|"
        Next
        If Len(FindString) &gt; 0 Then
            FindString = VBA.Left(FindString, Len(FindString) - 1)
        Else
            FindString = "Not found"
        End If
        Set objRegEx = Nothing
        Set colMatches = Nothing
        Set objMatch = Nothing
    End Function
     
    Private Function GetSender(olkItm As Object) As String
        Dim olkPA As Outlook.PropertyAccessor
        On Error Resume Next
        Set olkPA = olkItm.PropertyAccessor
        GetSender = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F001E")
        On Error GoTo 0
        Set olkPA = Nothing
    End Function
    
    • Hi, Søren.

      I think this will do it.

      Const OUTPUT_FILE_PATH = "C:\user\OutlookSaveTest\Address Harvest.csv"
      Dim objDic As Object
          
      Sub HarvestAddresses()
          Dim olkSto As Outlook.Store
          Set objDic = CreateObject("Scripting.Dictionary")
          For Each olkSto In Session.Stores
              ProcessFolder olkSto.GetRootFolder
          Next
          WriteListToFile
          Set olkSto = Nothing
          Set objDic = Nothing
          MsgBox "Done"
      End Sub
       
       
      Sub ProcessFolder(olkFld As Outlook.Folder)
          Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.recipient, intIdx As Integer, arrAdr As Variant, varAdr As Variant
          On Error Resume Next
          For Each olkItm In olkFld.Items
              DoEvents
              Select Case olkItm.Class
                  Case olAppointment
                      AddToList GetSenderAddress(olkItm), GetSenderName(olkItm)
                      For Each olkRcp In olkItm.Recipients
                          Select Case olkRcp.AddressEntry.AddressEntryUserType
                              Case olExchangeUserAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress, olkRcp.AddressEntry.GetExchangeUser.Name
                              Case olExchangeDistributionListAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress, olkRcp.AddressEntry.GetExchangeUser.Name
                              Case Else
                                  AddToList olkRcp.AddressEntry.Address, olkRcp.AddressEntry.Name
                          End Select
                      Next
                      arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                      For Each varAdr In arrAdr
                          AddToList varAdr
                      Next
                  Case olMail
                      If TypeName(olkItm.Sender) <> "Nothing" Then
                          If olkItm.Sender.AddressEntryUserType = olExchangeUserAddressEntry Then
                              AddToList olkItm.Sender.GetExchangeUser.PrimarySmtpAddress
                          Else
                              AddToList olkItm.SenderEmailAddress, olkItm.SenderName
                          End If
                      Else
                          If olkItm.SenderEmailAddress <> "" Then
                              AddToList olkItm.SenderEmailAddress, olkItm.SenderName
                          End If
                      End If
                      For Each olkRcp In olkItm.Recipients
                          Select Case olkRcp.AddressEntry.AddressEntryUserType
                              Case olExchangeUserAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress, olkRcp.AddressEntry.GetExchangeUser.Name
                              Case olExchangeDistributionListAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress, olkRcp.AddressEntry.GetExchangeUser.Name
                              Case Else
                                  AddToList olkRcp.AddressEntry.Address, olkRcp.AddressEntry.Name
                          End Select
                      Next
                      arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                      For Each varAdr In arrAdr
                          AddToList varAdr
                      Next
                  Case olContact
                      If olkItm.Email1Address <> "" Then AddToList olkItm.Email1Address
                      If olkItm.Email2Address <> "" Then AddToList olkItm.Email2Address
                      If olkItm.Email3Address <> "" Then AddToList olkItm.Email3Address
                  Case olDistList
                      For intIdx = 1 To olkItm.MemberCount
                          AddToList olkItm.GetMember(intIdx).AddressEntry.Address
                      Next
              End Select
          Next
          On Error GoTo 0
          For Each olkSubFld In olkFld.Folders
              ProcessFolder olkSubFld
              DoEvents
          Next
          Set olkItm = Nothing
          Set olkSubFld = Nothing
          Set olkRcp = Nothing
      End Sub
       
      Sub AddToList(varAdr As Variant, varNam As Variant)
          Dim varTmp As Variant
          varTmp = VBA.LCase(varAdr)
          If Not objDic.Exists(varTmp) Then
              objDic.Add VBA.LCase(varTmp), VBA.LCase(varNam)
          End If
      End Sub
       
      Sub WriteListToFile()
          Const ForWriting = 2
          Dim objFSO As Object, objFile As Object, arrVal As Variant, varVal As Variant
          Set objFSO = CreateObject("Scripting.FileSystemObject")
          Set objFile = objFSO.CreateTextFile(OUTPUT_FILE_PATH, ForWriting, True)
          arrVal = objDic.Items
          For Each varVal In arrVal
              objFile.WriteLine varVal
          Next
          objFile.Close
          Set objFile = Nothing
          Set objFSO = Nothing
      End Sub
         
      Private Function FindString(strText As String, strFind As String) As String
          Dim objRegEx As Object, colMatches As Object, objMatch As Object
          Set objRegEx = CreateObject("VBscript.RegExp")
          With objRegEx
              .IgnoreCase = True
              .Global = True
              .Pattern = strFind
              Set colMatches = .Execute(strText)
          End With
          For Each objMatch In colMatches
              FindString = FindString & objMatch.Value & "|"
          Next
          If Len(FindString) > 0 Then
              FindString = VBA.Left(FindString, Len(FindString) - 1)
          Else
              FindString = "Not found"
          End If
          Set objRegEx = Nothing
          Set colMatches = Nothing
          Set objMatch = Nothing
      End Function
        
      Private Function GetSenderAddress(olkItm As Object) As String
          Dim olkPA As Outlook.PropertyAccessor
          On Error Resume Next
          Set olkPA = olkItm.PropertyAccessor
          GetSenderAddress = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F001E")
          On Error GoTo 0
          Set olkPA = Nothing
      End Function
      
      Private Function GetSenderName(olkItm As Object) As String
          Dim olkPA As Outlook.PropertyAccessor
          On Error Resume Next
          Set olkPA = olkItm.PropertyAccessor
          GetSenderName = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1A001E")
          On Error GoTo 0
          Set olkPA = Nothing
      End Function
      
  2. Hi David
    Regarding your comment ” lready collects all occurrences. I could modify it to collect the date and you could then uses Excel’s ability to filter and sort to look at a given address and see the latest item it appears in. ”
    Yes please, that would be fine, thanks. BR Søren

    • HI, Søren.

      Sorry, but I’m a little lost on which version we’re talking about. Which one is it that you want modified?

  3. HI David
    Thank you very much. This is what I am looking for.
    But seems it only work when the subfolder has been selected, when I trying to run under the inbox folder, it give me runtime error 440.
    Can you help?
    Henry

    • Hi, Henry.

      There’s more than one instance of that line in the code. Which one is giving the error? A line number would help. Also, what do you mean when you say “under the inbox folder”? Does that mean the inbox folder itself or a folder under the inbox folder?

  4. Hi David
    Referring to David Lee December 7, 2016 @ 6:07 am
    Very fine Outlook macro.
    A few observations and questions.

    A
    I have started the macro by using F8 – After several minutes it stops here:
    Sub AddToList(varAdr As Variant)
    Dim varTmp As Variant
    varTmp = VBA.LCase(varAdr)
    If Not objDic.Exists(varTmp) Then
    objDic.Add VBA.LCase(varTmp), VBA.LCase(varTmp)
    End If
    End Sub
    And debug shows:
    Select Case olkRcp.AddressEntry.AddressEntryUserType ‘ Error here – under Case olMail (If F5 the error shows up quickly)

    Outlook crash when running the David Lee December 7, 2016 @ 6:07 am macro. And Outlook disable VBA so I have to enable it again [Disable VBA – Open File > Options > Add-Ins -> If the VBA for Outlook AddIn is in the “Disabled Application Add-Ins” list, please enable it: ]
    What is wrong with the December 7, 2016 @ 6:07 am Outlook macro?

    B
    Is it possible have both Sender, (ie. sender name, email addresses and subject – in separate column – that will make it more easy to understand who and what is what. The specific email address in sometime not enough to figure out who that is behind that

    • Hi, Søren.

      When the code fails, what is the error message? Let’s deal with the error first before discussing modifying he code to get the additional information you want.

    • Hi David
      cf. David Referring to David Lee December 7, 2016 @ 6:07
      cf. Søren January 19, 2017 @ 2:04 pm
      The error message is: ” Run-time error ‘-2010103803 (88304005)’ The operation failed

    • Hi, Søren.

      I can’t think of any reason why that error should occur at that point. It suggests that the recipient object currently being examined doesn’t have a AddressEntry object or the AddressEntry object doesn’t have an AddressEntryUserType property. Neither should be possible for mail items. Given that the code fails “after several minutes”, I’ll hypothesize that the item being processed at the time of the failure is damaged somehow. Assuming that hypothesis is correct, then we’d need to determine which item is being processed at the time of the failure. I can add code to the solution that will help us figure that out or we can employ a simpler solution and tell the code to ignore errors. That would cause the code to skip over the problem and continue processing. Which do you prefer?

    • Hi David
      In other VBA relating to Outlook I have had a problem with: Add and request read receipts and delivery notifications. I think that could cause issues. I suggest to test this. Ie. change the code so it skips any request read receipts and delivery notifications. Agree?

    • Hi, Søren.

      The code already skips read receipts and delivery notifications. They are a different item type. While they look like mail items they are actually report items. The code already filters them out.

    • Hi David
      I have had someone who do not use Outlook but webserver only to test the macro on a “new installation” on another pc where outlook has not been activated before. It runs the macro and no problems – it runs perfectly there. Without adding an email account the result was zero hits. With adding an email account the result was several hits. Therefore it seems that the code look at the webserver as there is no emails on this new installation? So the code will look at the webserver as well as own pc-installed Outlook? It could be good to know what cause the failure mentioned above. Anyway, for a start I think a workaround (ignore errors) will be the best choice. Any idea of what will be missing in the output? With the workaround the other improvements – B cf. above – could be established.
      Look forward to hear from you.

    • Hi David
      I have had someone who do not use Outlook but webserver only to test the macro on a “new installation” on another pc where outlook has not been activated before. It runs the macro and no problems – it runs perfectly there. Without adding an email account the result was zero hits. With adding an email account the result was several hits. Therefore it seems that the code look at the webserver as there is no emails on this new installation? So the code will look at the webserver as well as own pc-installed Outlook? It could be good to know what cause the failure mentioned above. Anyway, for a start I think a workaround (ignore errors) will be the best choice. Any idea of what will be missing in the output? With the workaround the other improvements – B cf. above – could be established.
      Look forward to hear from you.

    • Hi, Søren.

      The code you’re using processes all folders in all mailboxes and PST files. It only pays attention to mail items, appointments, contacts, and distribution lists. To determine what’s causing the error we’d need to identify the item the code is processing when the error occurs. We can do that if you want. The alternative is to ignore errors. That’ll cause the code to skip over the item that’s causing the problem. The result will be that the code won’t harvest some or all of the addresses from the item that’s causing the problem.

      I’ve modified the code in the ProcessFolder subroutine to ignore errors. Replace the ProcessFolder sub with the version below. Once you’ve done that, please run the code again and let me know what happens.

      Sub ProcessFolder(olkFld As Outlook.Folder)
          Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.recipient, intIdx As Integer, arrAdr As Variant, varAdr As Variant
          On Error Resume Next
          For Each olkItm In olkFld.Items
              DoEvents
              Select Case olkItm.Class
                  Case olAppointment
                      AddToList GetSender(olkItm)
                      For Each olkRcp In olkItm.Recipients
                          Select Case olkRcp.AddressEntry.AddressEntryUserType
                              Case olExchangeUserAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress
                              Case olExchangeDistributionListAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress
                              Case Else
                                  AddToList olkRcp.AddressEntry.Address
                          End Select
                      Next
                      arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                      For Each varAdr In arrAdr
                          AddToList varAdr
                      Next
                  Case olMail
                      If TypeName(olkItm.Sender) <> "Nothing" Then
                          If olkItm.Sender.AddressEntryUserType = olExchangeUserAddressEntry Then
                              AddToList olkItm.Sender.GetExchangeUser.PrimarySmtpAddress
                          Else
                              AddToList olkItm.SenderEmailAddress
                          End If
                      Else
                          If olkItm.SenderEmailAddress <> "" Then
                              AddToList olkItm.SenderEmailAddress
                          End If
                      End If
                      For Each olkRcp In olkItm.Recipients
                          Select Case olkRcp.AddressEntry.AddressEntryUserType
                              Case olExchangeUserAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress
                              Case olExchangeDistributionListAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress
                              Case Else
                                  AddToList olkRcp.AddressEntry.Address
                          End Select
                      Next
                      arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                      For Each varAdr In arrAdr
                          AddToList varAdr
                      Next
                  Case olContact
                      If olkItm.Email1Address <> "" Then AddToList olkItm.Email1Address
                      If olkItm.Email2Address <> "" Then AddToList olkItm.Email2Address
                      If olkItm.Email3Address <> "" Then AddToList olkItm.Email3Address
                  Case olDistList
                      For intIdx = 1 To olkItm.MemberCount
                          AddToList olkItm.GetMember(intIdx).AddressEntry.Address
                      Next
              End Select
          Next
          On Error Goto 0
          For Each olkSubFld In olkFld.Folders
              ProcessFolder olkSubFld
              DoEvents
          Next
          Set olkItm = Nothing
          Set olkSubFld = Nothing
          Set olkRcp = Nothing
      End Sub
      
    • Hi David
      Have tested and now it run without error. Perfect. Thanks. Can we go to part B (sender name, email addresses and subject)?
      If you want to spend the time, we can try to find the reason to the error later, but that is not urgent.
      Thanks again and look forward to hear from you.

    • Hi, Søren.

      Excellent! Glad it’s working.

      Concerning the additional details, why does it matter what message an address came from, especially since the solution is removing duplicates? Unless an address only appears once, then the additional details are going to come from the first message the address appears in. For example, say that the address joe@company.com appears in five messages. The code is only going to harvest it once, from the first message it appears in. That may or may not be the most significant of the messages the address is in. It may not even be a message. The first appearance might be in an appointment or a distribution list, in which case the code would get the details from there and would never record anything about all the other items that address appears in.

    • Hi David – I know that sender, email addresses and subject can give a duplicated problem – so maybe a msgbox where the user could choose A Latest sender name, email addresses and subject based on email address or B All and any mail (advise: save all as you risk that your pc will freeze and a restart is necessary)

    • Hi, Søren.

      Getting the latest appearance would require a fundamental change to how the code works. Right now the code de-duplicates addresses. Once it collects an address it ignores all future occurrences of it. In order to get the latest appearance I’d have to modify the code to collect the date of the item it appears in and compare the date of all other occurrences to that date. It’s doable, it just represents a major change. If you want that, then just switch to using the original version of the code rather than using the version that de-duplicates. That version already collects all occurrences. I could modify it to collect the date and you could then uses Excel’s ability to filter and sort to look at a given address and see the latest item it appears in.

    • Hi David
      Agree with “I could modify it to collect the date and you could then uses Excel’s ability to filter and sort to look at a given address and see the latest item it appears …” . That could be a fine ad on to the original version at the top of this page.

      When I receive an email is appears as “.TechnicLee [mailto:comment-reply@wordpress.com] so my point was to capture the TechnicLee and the comment-reply@wordpress.com. “Often” you could have an email address with x123z47@xmail.com and this give you no idea of who the sender is.

      Many thanks for your effort!!!!! The result de-duplicates (this one) and the original one (at the top of this page) is both very useful. Hope that many will use that and remember you and your effort and too recommend this/these solution(s). Thanks again.

    • Hi David
      “I could modify it to collect the date and you could then uses Excel’s ability to filter and sort to look at a given address and see the latest item it appears in.” That would be great.
      When I receive an e-mail from you it look like: TechnicLee [mailto:comment-reply@wordpress.com]
      I just want to capture all of this: “TechnicLee [mailto:comment-reply@wordpress.com]” . Is that possible too.
      BR Søren

  5. Hi David
    Good job done. I have a few questions.
    A
    Referring to David Lee December 7, 2016 @ 6:07 am above:
    Have run this code by using F8 A – After several minutes it stops here;
    Sub AddToList(varAdr As Variant)
    Dim varTmp As Variant
    varTmp = VBA.LCase(varAdr)
    If Not objDic.Exists(varTmp) Then
    objDic.Add VBA.LCase(varTmp), VBA.LCase(varTmp)
    End If
    End Sub
    And debug (press debug, not end) shows
    Select Case olkRcp.AddressEntry.AddressEntryUserType ‘ Error here – under Case olMail

    (That is the same issue as John Schwarz December 8, 2016 @ 5:19 pm mentioned above)

    [If you comment out the Case olMail part (start For Each olkRcp In olkItm.Recipients and end Next – both included) the rest seems to work – but then something is missing?).

    Do to the mentioned error the script disable VBA in Outlook (try to run by F5). I have to Enable VBA in Outlook again ( Disable VBA – Open File > Options > Add-Ins -> If the VBA for Outlook AddIn is in the “Disabled Application Add-Ins” list, please enable it: )

    Hmm – what is wrong with the above code?

    B
    Is it possible (and how) to get both Sender and email addresses with in the mentioned macro above – in separate columns (separate columns can be done when opening the CSV-file by Excel) – that will make it more easy to understand who that have the specific email address (maybe there will be some duplicates but that be handled by Excel).

    Hope you can help. Thank you in advance.

    • Hi David, thank you for your work here.

      The initial posted macro works.

      I’d also like to make use of the script that harvests email addresses and names, de-duplicates and outputs csv columns for EmailAddress, DisplayName.

      I’m a bit lost in all the iterations posted here, so not entirely sure which code to use.

      Can you help ?

      Thanks

    • Hi, timoto.

      The code isn’t designed to get display names, since the only display names it could get would be for internal addresses (i.e. those in your domain). It has no means of getting that info for external addresses. When I wrote this, my thought was that this would be used to harvest addresses from people outside of your organization since you already have the addresses of everyone in your organization. That said, here’s the version to use to harvest and deduplicate all addresses. This writes to a .txt file, not a .csv file.

      'Edit the file name and path on the next line.  This is the file the output will be written to.
      Const OUTPUT_FILE_PATH = "c:\myoutput.txt"
        
      Dim objDic As Object
         
      Sub HarvestAddresses()
          Dim olkSto As Outlook.Store
          Set objDic = CreateObject("Scripting.Dictionary")
          For Each olkSto In Session.Stores
              ProcessFolder olkSto.GetRootFolder
          Next
          WriteListToFile
          Set olkSto = Nothing
          Set objDic = Nothing
          MsgBox "Done"
      End Sub
         
      Sub ProcessFolder(olkFld As Outlook.Folder)
          Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.recipient, intIdx As Integer, arrAdr As Variant, varAdr As Variant
          For Each olkItm In olkFld.Items
              DoEvents
              Select Case olkItm.Class
                  Case olAppointment
                      AddToList GetSender(olkItm)
                      For Each olkRcp In olkItm.Recipients
                          Select Case olkRcp.AddressEntry.AddressEntryUserType
                              Case olExchangeUserAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress
                              Case olExchangeDistributionListAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress
                              Case Else
                                  AddToList olkRcp.AddressEntry.Address
                          End Select
                      Next
                      arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                      For Each varAdr In arrAdr
                          AddToList varAdr
                      Next
                  Case olMail
                      If TypeName(olkItm.Sender) <> "Nothing" Then
                          If olkItm.Sender.AddressEntryUserType = olExchangeUserAddressEntry Then
                              AddToList olkItm.Sender.GetExchangeUser.PrimarySmtpAddress
                          Else
                              AddToList olkItm.SenderEmailAddress
                          End If
                      Else
                          If olkItm.SenderEmailAddress <> "" Then
                              AddToList olkItm.SenderEmailAddress
                          End If
                      End If
                      For Each olkRcp In olkItm.Recipients
                          Select Case olkRcp.AddressEntry.AddressEntryUserType
                              Case olExchangeUserAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress
                              Case olExchangeDistributionListAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress
                              Case Else
                                  AddToList olkRcp.AddressEntry.Address
                          End Select
                      Next
                      arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                      For Each varAdr In arrAdr
                          AddToList varAdr
                      Next
                  Case olContact
                      If olkItm.Email1Address <> "" Then AddToList olkItm.Email1Address
                      If olkItm.Email2Address <> "" Then AddToList olkItm.Email2Address
                      If olkItm.Email3Address <> "" Then AddToList olkItm.Email3Address
                  Case olDistList
                      For intIdx = 1 To olkItm.MemberCount
                          AddToList olkItm.GetMember(intIdx).AddressEntry.Address
                      Next
              End Select
          Next
          For Each olkSubFld In olkFld.Folders
              ProcessFolder olkSubFld
              DoEvents
          Next
          Set olkItm = Nothing
          Set olkSubFld = Nothing
          Set olkRcp = Nothing
      End Sub
         
      Sub AddToList(varAdr As Variant)
          Dim varTmp As Variant
          varTmp = VBA.LCase(varAdr)
          If Not objDic.Exists(varTmp) Then
              objDic.Add VBA.LCase(varTmp), VBA.LCase(varTmp)
          End If
      End Sub
        
      Sub WriteListToFile()
          Const ForWriting = 2
          Dim objFSO As Object, objFile As Object, arrVal As Variant, varVal As Variant
          Set objFSO = CreateObject("Scripting.FileSystemObject")
          Set objFile = objFSO.CreateTextFile(OUTPUT_FILE_PATH, ForWriting, True)
          arrVal = objDic.Items
          For Each varVal In arrVal
              objFile.WriteLine varVal
          Next
          objFile.Close
          Set objFile = Nothing
          Set objFSO = Nothing
      End Sub
        
      Private Function FindString(strText As String, strFind As String) As String
          Dim objRegEx As Object, colMatches As Object, objMatch As Object
          Set objRegEx = CreateObject("VBscript.RegExp")
          With objRegEx
              .IgnoreCase = True
              .Global = True
              .Pattern = strFind
              Set colMatches = .Execute(strText)
          End With
          For Each objMatch In colMatches
              FindString = FindString & objMatch.Value & "|"
          Next
          If Len(FindString) > 0 Then
              FindString = VBA.Left(FindString, Len(FindString) - 1)
          Else
              FindString = "Not found"
          End If
          Set objRegEx = Nothing
          Set colMatches = Nothing
          Set objMatch = Nothing
      End Function
       
      Private Function GetSender(olkItm As Object) As String
          Dim olkPA As Outlook.PropertyAccessor
          On Error Resume Next
          Set olkPA = olkItm.PropertyAccessor
          GetSender = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F001E")
          On Error GoTo 0
          Set olkPA = Nothing
      End Function
      
    • Hello David

      Thank you for your help.

      I may be missing something here, but in Outlook 2016, if I double click on the external sender’s email address, who is not in my contacts and we have not made prior correspondence, I can see the Contact Email Properties dialog box which includes the “Display name” something like this:

      So there IS a “Display name” which may not be the same as “DisplayName” as far as Exchange is concerned.

      I imagine Outlook, as other email clients, creates a property using the From, Reply-to or To field which contains a format like this:

      “Joe Blogs”

      Whilst not all external contacts may bother to have their From field composed in this way, I suspect all bonafide contacts that I’m attempting to harvest will have.

      Now having a list of external contacts in a CSV, that have a DisplayName, which could also be split into FirstName and LastName, is a whole lot more useful than the email address alone.

      Is that something your script could be made to do ?

      Or am I barking up the wrong tree ?

      Thanks 🙂

    • Hello David

      Thank you for your help.

      I may be missing something here, but in Outlook 2016, if I double click on the external sender’s email address, who is not in my contacts and we have not made prior correspondence, I can see the Contact Email Properties dialog box which includes the “Display name” something like this:

      So there IS a “Display name” which may not be the same as “DisplayName” as far as Exchange is concerned.

      I imagine Outlook, as other email clients, creates a property using the From, Reply-to or To field which contains a format like this:

      "Joe Blogs"

      Whilst not all external contacts may bother to have their From field composed in this way, I suspect all bonafide contacts that I’m attempting to harvest will have.

      Now having a list of external contacts in a CSV, that have a DisplayName, which could also be split into FirstName and LastName, is a whole lot more useful than the email address alone.

      Is that something your script could be made to do ?

      Or am I barking up the wrong tree ?

      Thanks 🙂

    • Hi, timoto.

      You’re welcome.

      You’re partially correct. Outlook messages do have a property called SenderName which may contain the sender’s name. It may also contain the sender’s email address. The property is set by the sending email system. Outlook can only show the info the message contains. It has no means of figuring out the sender’s name from an email address.

      Please try this version. Note that I have not tested this code.

      Dim objFSO As Object, objFile As Object
       
      Sub HarvestAddresses()
          InitDatabase
          ProcessFolder Application.ActiveExplorer.CurrentFolder
          CloseDatabase
          MsgBox "Done"
      End Sub
       
      Sub ProcessFolder(olkFld As Outlook.Folder)
          Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.Recipient, intIdx As Integer
          For Each olkItm In olkFld.Items
              DoEvents
              Select Case olkItm.Class
                  Case olMail, olAppointment
                      WriteToDatabase olkItm.SenderName, olkItm.SenderEmailAddress
                      For Each olkRcp In olkItm.Recipients
                          WriteToDatabase olkRcp.Name, olkRcp.AddressEntry.Address
                      Next
                  Case olContact
                      If olkItm.Email1Address <> "" Then WriteToDatabase olkItm.FullName, olkItm.Email1Address
                      If olkItm.Email2Address <> "" Then WriteToDatabase olkItm.FullName, olkItm.Email2Address
                      If olkItm.Email3Address <> "" Then WriteToDatabase olkItm.FullName, olkItm.Email3Address
                  Case olDistList
                      For intIdx = 1 To olkItm.MemberCount
                          Set olkRcp = olkItm.GetMember(intIdx)
                          WriteToDatabase olkRcp.Name, olkRcp.AddressEntry.Address
                      Next
              End Select
          Next
          For Each olkSubFld In olkFld.Folders
              ProcessFolder olkSubFld
              DoEvents
          Next
          Set olkItm = Nothing
          Set olkSubFld = Nothing
          Set olkRcp = Nothing
      End Sub
       
      Sub InitDatabase()
          Const ForWriting = 2
          Set objFSO = CreateObject("Scripting.FileSystemObject")
          'Edit the file name and path on the next line
          Set objFile = objFSO.CreateTextFile("C:\users\david\documents\Address-Harvest.csv", ForWriting, True)
          objFile.WriteLine "Name,Address"
      End Sub
       
      Sub WriteToDatabase(strName As String, strAddress As String)
          objFile.WriteLine Chr(34) & strName & Chr(34) & "," & strAddress
      End Sub
       
      Sub CloseDatabase()
          objFile.Close
          Set objFile = Nothing
          Set objFSO = Nothing
      End Sub
      
  6. HI. I know this is an old post, but I’d appreciate if I can get some help. I’ve been searching the internet for days for this code! I don’t know any vba coding, but have been quite successful when copying other people’s written code. Is there any way you can provide the code above with all bugs fixed (I can’t figure out how to fix them myself), for the option to extract emails addresses from all fields, including the body (if there’s a way to remove duplicates, that would be great too). Nicola’s code has bugs in it (as mentioned) and I can’t figure out how to fix them. (I’m using outlook 2016) Thank you SO much!

    • Hi, BBB.

      I don’t really want to take the time to debug Nikola’s code and I have a different approach to finding the addresses in the message body. Instead, please use this version which, I believe, does everything you described.

      'Edit the file name and path on the next line.  This is the file the output will be written to.
      Const OUTPUT_FILE_PATH = "c:\myoutput.txt"
      
      Dim objDic As Object
       
      Sub HarvestAddresses()
          Set objDic = CreateObject("Scripting.Dictionary")
          ProcessFolder Application.ActiveExplorer.CurrentFolder
          WriteListToFile
          Set objDic = Nothing
          MsgBox "Done"
      End Sub
       
      Sub ProcessFolder(olkFld As Outlook.Folder)
          Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.recipient, intIdx As Integer, arrAdr As Variant, varAdr As Variant
          For Each olkItm In olkFld.Items
              DoEvents
              Select Case olkItm.Class
                  Case olMail, olAppointment
                      AddToList olkItm.SenderEmailAddress
                      For Each olkRcp In olkItm.Recipients
                          AddToList olkRcp.AddressEntry.Address
                      Next
                      arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                      For Each varAdr In arrAdr
                          AddToList varAdr
                      Next
                  Case olContact
                      If olkItm.Email1Address <> "" Then AddToList olkItm.Email1Address
                      If olkItm.Email2Address <> "" Then AddToList olkItm.Email2Address
                      If olkItm.Email3Address <> "" Then AddToList olkItm.Email3Address
                  Case olDistList
                      For intIdx = 1 To olkItm.MemberCount
                          AddToList olkItm.GetMember(intIdx).AddressEntry.Address
                      Next
              End Select
          Next
          For Each olkSubFld In olkFld.Folders
              ProcessFolder olkSubFld
              DoEvents
          Next
          Set olkItm = Nothing
          Set olkSubFld = Nothing
          Set olkRcp = Nothing
      End Sub
       
      Sub AddToList(varAdr As Variant)
          Dim varTmp As Variant
          varTmp = VBA.LCase(varAdr)
          If Not objDic.Exists(varTmp) Then
              objDic.Add VBA.LCase(varTmp), VBA.LCase(varTmp)
          End If
      End Sub
      
      Sub WriteListToFile()
          Const ForWriting = 2
          Dim objFSO As Object, objFile As Object, arrVal As Variant, varVal As Variant
          Set objFSO = CreateObject("Scripting.FileSystemObject")
          Set objFile = objFSO.CreateTextFile(OUTPUT_FILE_PATH, ForWriting, True)
          arrVal = objDic.Items
          For Each varVal In arrVal
              objFile.WriteLine varVal
          Next
          objFile.Close
          Set objFile = Nothing
          Set objFSO = Nothing
      End Sub
      
      Private Function FindString(strText As String, strFind As String) As String
          Dim objRegEx As Object, colMatches As Object, objMatch As Object
          Set objRegEx = CreateObject("VBscript.RegExp")
          With objRegEx
              .IgnoreCase = True
              .Global = True
              .Pattern = strFind
              Set colMatches = .Execute(strText)
          End With
          For Each objMatch In colMatches
              FindString = FindString & objMatch.Value & "|"
          Next
          If Len(FindString) > 0 Then
              FindString = VBA.Left(FindString, Len(FindString) - 1)
          Else
              FindString = "Not found"
          End If
          Set objRegEx = Nothing
          Set colMatches = Nothing
          Set objMatch = Nothing
      End Function
      
    • Thank you very much! You are really helpful!
      I ran the code, and I get a run-time error ’70’
      Debugger points to this line:
      Set objFile = objFSO.CreateTextFile(OUTPUT_FILE_PATH, ForWriting, True)

      Do you know why this is happening?

      Also, I know this is a new request, but is it possible to search not only the “current folder” and subfolders, but also the other root folders and subfolders? (Basically Inbox, Sent Items, and Deleted Items.)

      Thank you!!

    • Hi, BBB.

      Did you set the value of OUTPUT_FILE_PATH at the top of the code?

      To search the folders you listed, replace the HarvestAddresses subroutine with the one below.

      Sub HarvestAddresses()
          Set objDic = CreateObject("Scripting.Dictionary")
          ProcessFolder Session.GetDefaultFolder(olFolderInbox)
          ProcessFolder Session.GetDefaultFolder(olFolderSentMail)
          ProcessFolder Session.GetDefaultFolder(olFolderDeletedItems)
          WriteListToFile
          Set objDic = Nothing
          MsgBox "Done"
      End Sub
      
    • David,
      You are great at this. I was trying to do all the cut & pastes from the thread, and am not smart enough to know which ones to include.
      I haven’t done any of this since the ANSI/DOS days of the late 80’s, so I’m a VBS newbie. Running Win7pro Outlook2010, hard drive fried and backups were corrupted (yes it sux). All contact emails lost, but can mine them out of old emails.

      When I copied the Nov30 post, it only returned 3 addresses from 130,000 emails; so I’ve done something wrong. Output file is “E:\mineaddresses12.csv” to flash drive. It opens clean in Excel.

      If there is a way to do all “personal folders” in one shot, that would be phenomenal… although it would probably take several hours to process.
      I will delete all of the attempted macro saves and await your reply.

      I repectfully ask that you please post an idiot-proof code whenever convenient.

      Thanks,
      John

    • Hi, John.

      Thanks!

      Please try this version. It should harvest the addresses from every item in every folder you have. It also de-duplicates the addresses. Depending on how many folders you have and how many items are in each folder, it may take a long time to run.

      'Edit the file name and path on the next line.  This is the file the output will be written to.
      Const OUTPUT_FILE_PATH = "c:\myoutput.txt"
       
      Dim objDic As Object
        
      Sub HarvestAddresses()
          Dim olkSto As Outlook.Store
          Set objDic = CreateObject("Scripting.Dictionary")
          For Each olkSto In Session.Stores
              ProcessFolder olkSto.GetRootFolder
          Next
          WriteListToFile
          Set olkSto = Nothing
          Set objDic = Nothing
          MsgBox "Done"
      End Sub
        
      Sub ProcessFolder(olkFld As Outlook.Folder)
          Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.recipient, intIdx As Integer, arrAdr As Variant, varAdr As Variant
          For Each olkItm In olkFld.Items
              DoEvents
              Select Case olkItm.Class
                  Case olAppointment
                      AddToList GetSender(olkItm)
                      For Each olkRcp In olkItm.Recipients
                          Select Case olkRcp.AddressEntry.AddressEntryUserType
                              Case olExchangeUserAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress
                              Case olExchangeDistributionListAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress
                              Case Else
                                  AddToList olkRcp.AddressEntry.Address
                          End Select
                      Next
                      arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                      For Each varAdr In arrAdr
                          AddToList varAdr
                      Next
                  Case olMail
                      If TypeName(olkItm.Sender) <> "Nothing" Then
                          If olkItm.Sender.AddressEntryUserType = olExchangeUserAddressEntry Then
                              AddToList olkItm.Sender.GetExchangeUser.PrimarySmtpAddress
                          Else
                              AddToList olkItm.SenderEmailAddress
                          End If
                      Else
                          If olkItm.SenderEmailAddress <> "" Then
                              AddToList olkItm.SenderEmailAddress
                          End If
                      End If
                      For Each olkRcp In olkItm.Recipients
                          Select Case olkRcp.AddressEntry.AddressEntryUserType
                              Case olExchangeUserAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress
                              Case olExchangeDistributionListAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress
                              Case Else
                                  AddToList olkRcp.AddressEntry.Address
                          End Select
                      Next
                      arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                      For Each varAdr In arrAdr
                          AddToList varAdr
                      Next
                  Case olContact
                      If olkItm.Email1Address <> "" Then AddToList olkItm.Email1Address
                      If olkItm.Email2Address <> "" Then AddToList olkItm.Email2Address
                      If olkItm.Email3Address <> "" Then AddToList olkItm.Email3Address
                  Case olDistList
                      For intIdx = 1 To olkItm.MemberCount
                          AddToList olkItm.GetMember(intIdx).AddressEntry.Address
                      Next
              End Select
          Next
          For Each olkSubFld In olkFld.Folders
              ProcessFolder olkSubFld
              DoEvents
          Next
          Set olkItm = Nothing
          Set olkSubFld = Nothing
          Set olkRcp = Nothing
      End Sub
        
      Sub AddToList(varAdr As Variant)
          Dim varTmp As Variant
          varTmp = VBA.LCase(varAdr)
          If Not objDic.Exists(varTmp) Then
              objDic.Add VBA.LCase(varTmp), VBA.LCase(varTmp)
          End If
      End Sub
       
      Sub WriteListToFile()
          Const ForWriting = 2
          Dim objFSO As Object, objFile As Object, arrVal As Variant, varVal As Variant
          Set objFSO = CreateObject("Scripting.FileSystemObject")
          Set objFile = objFSO.CreateTextFile(OUTPUT_FILE_PATH, ForWriting, True)
          arrVal = objDic.Items
          For Each varVal In arrVal
              objFile.WriteLine varVal
          Next
          objFile.Close
          Set objFile = Nothing
          Set objFSO = Nothing
      End Sub
       
      Private Function FindString(strText As String, strFind As String) As String
          Dim objRegEx As Object, colMatches As Object, objMatch As Object
          Set objRegEx = CreateObject("VBscript.RegExp")
          With objRegEx
              .IgnoreCase = True
              .Global = True
              .Pattern = strFind
              Set colMatches = .Execute(strText)
          End With
          For Each objMatch In colMatches
              FindString = FindString & objMatch.Value & "|"
          Next
          If Len(FindString) > 0 Then
              FindString = VBA.Left(FindString, Len(FindString) - 1)
          Else
              FindString = "Not found"
          End If
          Set objRegEx = Nothing
          Set colMatches = Nothing
          Set objMatch = Nothing
      End Function
      
      Private Function GetSender(olkItm As Object) As String
          Dim olkPA As Outlook.PropertyAccessor
          On Error Resume Next
          Set olkPA = olkItm.PropertyAccessor
          GetSender = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F001E")
          On Error GoTo 0
          Set olkPA = Nothing
      End Function
      
    • David,
      It is in the:
      For Each olkRcp In olkItm.Recipients
      Select Case olkRcp.AddressEntry.AddressEntryUserType
      Case olExchangeUserAddressEntry
      section.
      If you have any thoughts, please so advise. The output path is correct. There may be an “all mail folders” switch option.

      Regards,
      John

      ‘Edit the file name and path on the next line. This is the file the output will be written to.
      Const OUTPUT_FILE_PATH = “E:\emailminer.txt”

      Dim objDic As Object

      Sub HarvestAddresses()
      Dim olkSto As Outlook.Store
      Set objDic = CreateObject(“Scripting.Dictionary”)
      For Each olkSto In Session.Stores
      ProcessFolder olkSto.GetRootFolder
      Next
      WriteListToFile
      Set olkSto = Nothing
      Set objDic = Nothing
      MsgBox “Done”
      End Sub

      Sub ProcessFolder(olkFld As Outlook.Folder)
      Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.Recipient, intIdx As Integer, arrAdr As Variant, varAdr As Variant
      For Each olkItm In olkFld.Items
      DoEvents
      Select Case olkItm.Class
      Case olAppointment
      AddToList GetSender(olkItm)
      For Each olkRcp In olkItm.Recipients
      Select Case olkRcp.AddressEntry.AddressEntryUserType
      Case olExchangeUserAddressEntry
      AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress
      Case olExchangeDistributionListAddressEntry
      AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress
      Case Else
      AddToList olkRcp.AddressEntry.Address
      End Select
      Next
      arrAdr = Split(FindString(olkItm.Body, “\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b”), “|”)
      For Each varAdr In arrAdr
      AddToList varAdr
      Next
      Case olMail
      If TypeName(olkItm.Sender) “Nothing” Then
      If olkItm.Sender.AddressEntryUserType = olExchangeUserAddressEntry Then
      AddToList olkItm.Sender.GetExchangeUser.PrimarySmtpAddress
      Else
      AddToList olkItm.SenderEmailAddress
      End If
      Else
      If olkItm.SenderEmailAddress “” Then
      AddToList olkItm.SenderEmailAddress
      End If
      End If
      For Each olkRcp In olkItm.Recipients
      Select Case olkRcp.AddressEntry.AddressEntryUserType
      Case olExchangeUserAddressEntry
      AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress
      Case olExchangeDistributionListAddressEntry
      AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress
      Case Else
      AddToList olkRcp.AddressEntry.Address
      End Select
      Next
      arrAdr = Split(FindString(olkItm.Body, “\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b”), “|”)
      For Each varAdr In arrAdr
      AddToList varAdr
      Next
      Case olContact
      If olkItm.Email1Address “” Then AddToList olkItm.Email1Address
      If olkItm.Email2Address “” Then AddToList olkItm.Email2Address
      If olkItm.Email3Address “” Then AddToList olkItm.Email3Address
      Case olDistList
      For intIdx = 1 To olkItm.MemberCount
      AddToList olkItm.GetMember(intIdx).AddressEntry.Address
      Next
      End Select
      Next
      For Each olkSubFld In olkFld.Folders
      ProcessFolder olkSubFld
      DoEvents
      Next
      Set olkItm = Nothing
      Set olkSubFld = Nothing
      Set olkRcp = Nothing
      End Sub

      Sub AddToList(varAdr As Variant)
      Dim varTmp As Variant
      varTmp = VBA.LCase(varAdr)
      If Not objDic.Exists(varTmp) Then
      objDic.Add VBA.LCase(varTmp), VBA.LCase(varTmp)
      End If
      End Sub

      Sub WriteListToFile()
      Const ForWriting = 2
      Dim objFSO As Object, objFile As Object, arrVal As Variant, varVal As Variant
      Set objFSO = CreateObject(“Scripting.FileSystemObject”)
      Set objFile = objFSO.CreateTextFile(OUTPUT_FILE_PATH, ForWriting, True)
      arrVal = objDic.Items
      For Each varVal In arrVal
      objFile.WriteLine varVal
      Next
      objFile.Close
      Set objFile = Nothing
      Set objFSO = Nothing
      End Sub

      Private Function FindString(strText As String, strFind As String) As String
      Dim objRegEx As Object, colMatches As Object, objMatch As Object
      Set objRegEx = CreateObject(“VBscript.RegExp”)
      With objRegEx
      .IgnoreCase = True
      .Global = True
      .Pattern = strFind
      Set colMatches = .Execute(strText)
      End With
      For Each objMatch In colMatches
      FindString = FindString & objMatch.Value & “|”
      Next
      If Len(FindString) > 0 Then
      FindString = VBA.Left(FindString, Len(FindString) – 1)
      Else
      FindString = “Not found”
      End If
      Set objRegEx = Nothing
      Set colMatches = Nothing
      Set objMatch = Nothing
      End Function

      Private Function GetSender(olkItm As Object) As String
      Dim olkPA As Outlook.PropertyAccessor
      On Error Resume Next
      Set olkPA = olkItm.PropertyAccessor
      GetSender = olkPA.GetProperty(“http://schemas.microsoft.com/mapi/proptag/0x0C1F001E”)
      On Error GoTo 0
      Set olkPA = Nothing
      End Function

      John Schwarz
      December 7, 2016 @ 10:12 am

      Thank you again. Here is the debug line for the run time error:
      Select Case olkRcp.AddressEntry.AddressEntryUserType
      1387003633 (ad54010f) an object could not be found
      David Lee
      December 7, 2016 @ 1:44 pm

      Hi, John.

      olkRcp should point to a recipient object in the item’s list of recipients. The error message suggests that the object named olkRcp is empty. However, the script can only get to that line of code if the list of recipients isn’t empty. If the list of recipients isn’t empty, then olkRcp should always contain a recipient object making it impossible for that error to occur. There’s more than one instance of that line in the code. Do you know which instance it failed on?

    • Hi, John.

      That block of code appears in two places. I need to know which instance it is. Is it the one under the “Case olAppointment” or the one under the “Case olMail”?

    • I have made all of the recommended changes to the script given to BBB, it is saying an ambiguous name detected: GetSender
      No idea how to solve this problem. I have never used codes like this before. Please assist!

    • Hi, Erin.

      An “ambiguous name” error means that there are two or more subroutine or functions with the same name. In this case, it’s telling you that there are at least two functions named GetSender. That could be because there was already a GetSender function in Outlook when you added this code or you mistakenly pasted the code in twice. To fix this, delete all but one of the GetSender functions.

  7. Hi David,
    Im trying to harvest all addresses from received emails (not saved as contacts – silly me) in outlook 2013. I cant follow your instruction above as by the time i get to step 2, i cant follow the details. My PC seems to have different settings. Would genuinely appreciate your assistance please. Thank you so much!

    • Thank you for all your help!

      I changed the output path (although the first one I used should have worked). Now I get a new run-time error ‘438’ Object doesn’t support this property or method.
      It highlights this line:
      AddToList olkItm.SenderEmailAddress

      Do you know why this is happening?

      Thank you!!

    • BBB,

      I think I see the problem. Replace the ProcessFolder subroutine with the version below.

      Sub ProcessFolder(olkFld As Outlook.Folder)
          Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.recipient, intIdx As Integer, arrAdr As Variant, varAdr As Variant
          For Each olkItm In olkFld.Items
              DoEvents
              Set olkItm = Application.ActiveExplorer.Selection(1)
              Select Case olkItm.Class
                  Case olAppointment
                      AddToList GetSender(olkItm)
                      For Each olkRcp In olkItm.Recipients
                          AddToList olkRcp.AddressEntry.Address
                      Next
                      arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                      For Each varAdr In arrAdr
                          AddToList varAdr
                      Next
                  Case olMail
                      AddToList olkItm.SenderEmailAddress
                      For Each olkRcp In olkItm.Recipients
                          AddToList olkRcp.AddressEntry.Address
                      Next
                      arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                      For Each varAdr In arrAdr
                          AddToList varAdr
                      Next
                  Case olContact
                      If olkItm.Email1Address <> "" Then AddToList olkItm.Email1Address
                      If olkItm.Email2Address <> "" Then AddToList olkItm.Email2Address
                      If olkItm.Email3Address <> "" Then AddToList olkItm.Email3Address
                  Case olDistList
                      For intIdx = 1 To olkItm.MemberCount
                          AddToList olkItm.GetMember(intIdx).AddressEntry.Address
                      Next
              End Select
          Next
          For Each olkSubFld In olkFld.Folders
              ProcessFolder olkSubFld
              DoEvents
          Next
          Set olkItm = Nothing
          Set olkSubFld = Nothing
          Set olkRcp = Nothing
      End Sub
      

      Add this function to the code you already have.

      Private Function GetSender(olkItm As Object) As String
          Dim olkPA As Outlook.PropertyAccessor
          On Error Resume Next
          Set olkPA = olkItm.PropertyAccessor
          GetSender = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F001E")
          On Error GoTo 0
          Set olkPA = Nothing
      End Function
      
    • Thank you again. Here is the debug line for the run time error:
      Select Case olkRcp.AddressEntry.AddressEntryUserType
      1387003633 (ad54010f) an object could not be found

    • Hi, John.

      olkRcp should point to a recipient object in the item’s list of recipients. The error message suggests that the object named olkRcp is empty. However, the script can only get to that line of code if the list of recipients isn’t empty. If the list of recipients isn’t empty, then olkRcp should always contain a recipient object making it impossible for that error to occur. There’s more than one instance of that line in the code. Do you know which instance it failed on?

  8. Hello

    I have installed this in Outlook 2007 and I am getting an Compile Error: Syntax Error on the

    Sub InitDatabase()
    Const ForWriting = 2
    Set objFSO = CreateObject(“Scripting.FileSystemObject”)
    ‘Edit the file name and path on the next line
    Set objFile = objFSO.CreateTextFile(“D:\Outlook_Folders\EMail_Addresses_to_Purge.txt”, ForWriting, True)

    End Sub

    The Set objFile Line is Highlighted Blue and when you click the OK button on the Error Message Box the Sub InitDatabase() line turns Yellow.

    Any Ideas?

    • Hi, PappaSmurf.

      My best guess is that the double-quotes that enclose the path are invalid. Try deleting and re-entering them.

    • Thank you so much for your help! Sorry for the delayed response. I was out, and didn’t get a chance to test the new code until now. I feel terrible wasting your time, but I really don’t know who else I can possibly ask for help. I ran the updated code. I have thousands of email addresses in my inbox, but the output file “myoutput.txt” returns only 3 -5 lines (depending which folder is open when I run the code):
      /o=exchangelabs/ou=exchange administrative group (….)/cn=recipients/cn=…
      /o=exchangelabs/ou=exchange administrative group (…)/cn=recipients/cn=…
      mary.kellxxx@xxx.com
      Do you know why this is happening?

    • Hi, BBB.

      You’re seeing some addresses like “/o=exchangelabs/ou=exchange administrative group (….)/cn=recipients/cn=…”, because this is Exchange’s internal addressing. Exchange doesn’t use SMTP addresses natively, it uses this format instead. I’ve modified the code to attempt to get the SMTP address instead of the native address. Replace the ProcessFolder sub with the version below. I also fixed the problem that was limiting the number of addresses being exported.

      Sub ProcessFolder(olkFld As Outlook.Folder)
          Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.recipient, intIdx As Integer, arrAdr As Variant, varAdr As Variant
          For Each olkItm In olkFld.Items
              DoEvents
              Select Case olkItm.Class
                  Case olAppointment
                      AddToList GetSender(olkItm)
                      For Each olkRcp In olkItm.Recipients
                          Select Case olkRcp.AddressEntry.AddressEntryUserType
                              Case olExchangeUserAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress
                              Case olExchangeDistributionListAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress
                              Case Else
                                  AddToList olkRcp.AddressEntry.Address
                          End Select
                      Next
                      arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                      For Each varAdr In arrAdr
                          AddToList varAdr
                      Next
                  Case olMail
                      If TypeName(olkItm.Sender) <> "Nothing" Then
                          If olkItm.Sender.AddressEntryUserType = olExchangeUserAddressEntry Then
                              AddToList olkItm.Sender.GetExchangeUser.PrimarySmtpAddress
                          Else
                              AddToList olkItm.SenderEmailAddress
                          End If
                      Else
                          If olkItm.SenderEmailAddress <> "" Then
                              AddToList olkItm.SenderEmailAddress
                          End If
                      End If
                      For Each olkRcp In olkItm.Recipients
                          Select Case olkRcp.AddressEntry.AddressEntryUserType
                              Case olExchangeUserAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress
                              Case olExchangeDistributionListAddressEntry
                                  AddToList olkRcp.AddressEntry.GetExchangeDistributionList.PrimarySmtpAddress
                              Case Else
                                  AddToList olkRcp.AddressEntry.Address
                          End Select
                      Next
                      arrAdr = Split(FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"), "|")
                      For Each varAdr In arrAdr
                          AddToList varAdr
                      Next
                  Case olContact
                      If olkItm.Email1Address <> "" Then AddToList olkItm.Email1Address
                      If olkItm.Email2Address <> "" Then AddToList olkItm.Email2Address
                      If olkItm.Email3Address <> "" Then AddToList olkItm.Email3Address
                  Case olDistList
                      For intIdx = 1 To olkItm.MemberCount
                          AddToList olkItm.GetMember(intIdx).AddressEntry.Address
                      Next
              End Select
          Next
          For Each olkSubFld In olkFld.Folders
              ProcessFolder olkSubFld
              DoEvents
          Next
          Set olkItm = Nothing
          Set olkSubFld = Nothing
          Set olkRcp = Nothing
      End Sub
      
  9. Hi David,

    I love this stuff, and your desire to help some of us out that are no where near the level that you are.

    Do you have an idea if its possible to extract email signatures from the email body? I was trying to search on forums over the last few weeks and havent found much for answers to this. I would imagine there might be something embedded in the email that would indicate a section of the body to house the signature information.

    What are your thoughts on this? Do you think there is a simple solution to harvesting that content (name, job title, phone numbers, email)?

    • Hi, Seth.

      I’m not aware of any convention for denoting signatures in emails. Outlook certainly knows where the signature goes when creating or replying to a message, but I don’t know that it knows where the signature is in a received message. If all messages were in HTML, then it might use a div or some special set of tags. But not all messages are in HTML. Some are in plain-text. Unless the message logged an offset to and length of the signature, then I don’t know how it could distinguish the signature from the rest of the message. Also, some senders use a graphic for their signature. It’d be difficult to convert the graphic to text so you could parse the information from it. Even for textual signatures it’d not that simple to figure out all the pieces. Telephone numbers are a good example. Some signatures prefix each number with a word telling the reader that it’s office, mobile, or fax. The words aren’t always the same though. Some signatures might use desk and cell instead of office and mobile. Some use letters in lieu of words (e.g. d for desk, m for mobile, o for office) while others use icons. It would be difficult for a solution to correctly determine what each number is. Then there are the numbers themselves. Some signatures use a dash to separate the groups, others use periods, while others run them all together. It’s just not a simple process.

  10. David,

    Excellent piece of code and it works great, thanks. I was going to ask if this grabs the addresses from the “From” field or from the body as well but then I noticed Nikola’s post. Unfortunately, his isn’t working for me, any thoughts?

    • Hi, Jim.

      I never tested Nikola’s code to see if it works or not. My code pulls the sender’s address and the addresses of everyone the message was addressed to. It does not pull addresses from the body of the message. I can add that capability though. To do that, add this function to the code from my post.

      Private Function FindString(strText As String, strFind As String) As String
          Dim objRegEx As Object, colMatches As Object, objMatch As Object
          Set objRegEx = CreateObject("VBscript.RegExp")
          With objRegEx
              .IgnoreCase = True
              .Global = True
              .Pattern = strFind
              Set colMatches = .Execute(strText)
          End With
          If colMatches.Count > 0 Then
              For Each objMatch In colMatches
                  FindString = FindString & objMatch.Value & "|"
              Next
              FindString = Left(FindString, Len(FindString) - 1)
          Else
              FindString = "Not found"
          End If
          Set objRegEx = Nothing
          Set colMatches = Nothing
          Set objMatch = Nothing
      End Function
      

      Once that’s done, replace the ProcessFolder subroutine from my original post with the version below.

      Sub ProcessFolder(olkFld As Outlook.Folder)
          Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.Recipient, intIdx As Integer, strBuf As String, arrItm As Variant, varItm As Variant
          For Each olkItm In olkFld.Items
              DoEvents
              Select Case olkItm.Class
                  Case olMail, olAppointment
                      WriteToDatabase olkItm.SenderEmailAddress
                      For Each olkRcp In olkItm.Recipients
                          WriteToDatabase olkRcp.AddressEntry.Address
                      Next
                      strBuf = FindString(olkItm.Body, "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b")
                      If strBuf <> "Not found" Then
                          arrItm = Split(strBuf, "|")
                          For Each varItm In arrItm
                              WriteToDatabase varItm
                          Next
                      End If
                  Case olContact
                      If olkItm.Email1Address <> "" Then WriteToDatabase olkItm.Email1Address
                      If olkItm.Email2Address <> "" Then WriteToDatabase olkItm.Email2Address
                      If olkItm.Email3Address <> "" Then WriteToDatabase olkItm.Email3Address
                  Case olDistList
                      For intIdx = 1 To olkItm.MemberCount
                          WriteToDatabase olkItm.GetMember(intIdx).AddressEntry.Address
                      Next
              End Select
          Next
          For Each olkSubFld In olkFld.Folders
              ProcessFolder olkSubFld
              DoEvents
          Next
          Set olkItm = Nothing
          Set olkSubFld = Nothing
          Set olkRcp = Nothing
      End Sub
      

      The solution should now harvest all email addresses from the message or appointment body.

    • Hi, Jim.

      In the new ProcessFolder subroutine change this line

      WriteToDatabase varItm
      

      to

      WriteToDatabase CStr(varItm)
      
    • David…..you are the MAN! That did the trick. I am able to now harvest email addresses from the body. I am a Realtor and I get a lot of emails from other agents that use an automated system to mass mail listings and the return address is a system address but they post their personal address within the body. This is great, thanks again.

  11. Hi, this is exactly what i’ve been looking for. although i am looking for one additional feature, which would be to include the “email subject title” that the email address was originally found in. is there a simple way to capture that information in this?

    thanks,
    Jason

    • Hi, Jason.

      Replace the ProcessFolder and WriteToDatabase subroutines with the versions below. Leave the rest of the code as is. This version writes the subject line with the sender’s email address for emails.

      Sub ProcessFolder(olkFld As Outlook.Folder)
          Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.Recipient, intIdx As Integer
          For Each olkItm In olkFld.Items
              DoEvents
              Select Case olkItm.Class
                  Case olMail, olAppointment
                      WriteToDatabase olkItm.SenderEmailAddress
                      For Each olkRcp In olkItm.Recipients
                          WriteToDatabase olkRcp.AddressEntry.Address, olkItm.Subject
                      Next
                  Case olContact
                      If olkItm.Email1Address <> "" Then WriteToDatabase olkItm.Email1Address
                      If olkItm.Email2Address <> "" Then WriteToDatabase olkItm.Email2Address
                      If olkItm.Email3Address <> "" Then WriteToDatabase olkItm.Email3Address
                  Case olDistList
                      For intIdx = 1 To olkItm.MemberCount
                          WriteToDatabase olkItm.GetMember(intIdx).AddressEntry.Address
                      Next
              End Select
          Next
          For Each olkSubFld In olkFld.Folders
              ProcessFolder olkSubFld
              DoEvents
          Next
          Set olkItm = Nothing
          Set olkSubFld = Nothing
          Set olkRcp = Nothing
      End Sub
      
      Sub WriteToDatabase(strAddress As String, Optional strSubject As String)
          objFile.WriteLine strAddress & vbTab & strSubject
      End Sub
      
    • Hi, Carl.

      Yes, that’s possible. The simplest solution would be to modify the code to create a .csv which you’d then open in Excel. Would that be okay?

    • Carl,

      Change line 43 of the code from

          Set objFile = objFSO.CreateTextFile("C:\eeTesting\Address Harvest.txt", ForWriting, True)
      

      to

          Set objFile = objFSO.CreateTextFile("C:\eeTesting\Address Harvest.csv", ForWriting, True)
      
  12. Hi there,
    I am a VB n00b, please be gentle!
    This works well but returns exchange server and lanID data, as opposed to the email addresses themselves.
    I suspect this works fine on a non exchange setup.
    Is there any way to extract the email addresses behind the lanIDs?
    many thanks!

    • Him Johnny.

      What you’re seeing isn’t a LAN ID. It’s an address, just not an SMTP address, which is what you’re used to seeing. Exchange server uses that form of address internally. The solution is to add some code that converts the address into SMTP format. What version of Outlook are you using? I need to know that to determine how to make the conversion.

    • What sort of code would you need to add to convert all email address that aren’t already in SMTP format, into SMTP format before placing them in the extract file? And whereabouts within the main code would it need to be placed to work correctly? I am using Outlook 2013.

    • Hi, Oz.

      This should do it. I’m not in a position to test right now, so there could be a bug I’ve missed.

      Function GetSMTP(olkAdr As Outlook.AddressEntry) As String
          Dim olkEnt As Outlook.ExchangeUser
          If olkAdr.AddressEntryUserType = olExchangeUserAddressEntry Then
              Set olkEnt = olkAdr.GetExchangeUser
              GetSMTP = olkEnt.PrimarySmtpAddress
          Else
              GetSMTP = olkAdr.Address
          End If
      End Function
      

      To use this, change lines 16 – 19 to

      WriteToDatabase olkItm.Sender
      For Each olkRcp In olkItm.Recipients
          WriteToDatabase GetSMTP(olkRcp.AddressEntry)
      Next
      
  13. Seem to be getting a syntax error on the below code:

    Sub InitDatabase()
    Const ForWriting = 2
    Set objFSO = CreateObject(“Scripting.FileSystemObject”)
    ‘Edit the file name and path on the next line
    Set objFile = objFSO.CreateTextFile(“C:\mail\Address Harvest.txt”, ForWriting, True)

    End Sub

    Do you think this is becuase i’m running Outlook 2013?

  14. Hi all, I have been searching for something like this BUT … does anyone have a version I can use on my Mac ? With Mac mail ? Please.

  15. Thanks, that’s exactly what I was looking for.

    I just added a small modification and implemented one of the open TODOs: it now eliminates duplicates.

    For those who are interested in the solution. I’ve just added a global variable “Dim addressCollection As Collection”. This collection is being initialized in the InitDatabase sub “Set addressCollection = New Collection”. I’ve added a function for checking whether a string is part of the collection:

    Private Function HasStringItem(itemCollection As Collection, searchString As String)
        Dim i As Integer
        For i = 1 To itemCollection.Count
            If (itemCollection.Item(i) = searchString) Then
                HasStringItem = True
                Exit Function
            End If
        Next i
        HasStringItem = False
    End Function
    

    And this function is being called in the WriteToDatabase sub:

    Sub WriteToDatabase(strAddress As String)
        If HasStringItem(addressCollection, strAddress) Then
            Exit Sub
        End If
        objFile.WriteLine strAddress
        addressCollection.Add (strAddress)
    End Sub
    

    Thanks and regards,
    Patric

    • Hi, Fiona.

      The solution should work after you change this line

      Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.Recipient, intIdx As Integer
      

      to

      Dim olkItm As Object, olkSubFld As Object, olkRcp As Outlook.Recipient, intIdx As Integer
      
  16. Hi, Just want to say you’re the best of the best. I’ve never found code that was so easily explained and worked so flawlessly. Just sending you giant props! Thanks.

    Mark

  17. Nikola, as far as the codepage interpretation goes, the main issues (including in the new post), are the single quote (for comments), the double quote for strings, and the minus sign.

    Function WriteToDatabase is missing an “End If” statement around the body of the function, unless the last “If” statement is “in line”.

    Function “FindAddress() did not make the posting, so I commented it out.

    The functions AdrLeft and AdrRight are not called anywhere (presumably these are called in FindAddress() ?)

    Additionally, the “while” loops in AdrLeft and AdrRight have argument issues.

    • Dale,

      You are absolutely right about some issues. All of them comes because I can’t copy/paste original code without changes here. Probably there are some editor or cms limitations to do that. Because of that, I will try to post here a link to the txt file which works as expected.

      Here it is: http://bold-brand.com/macro.txt
      I hope ti will works to you, same good as for me.

  18. It is wonderful script! It was exactly what I needed. Moreover, I made upgrade to it. I made extension in order to harvest mail body for addresses and to extract first and last name where it is possible.
    I want to share it here and to save someone’s time at the same way this script saved mine. I hope someone will find it useful.

    Dim objFSO As Object, objFile As Object
    
    Sub HarvestAddresses()
        InitDatabase
        ProcessFolder Application.ActiveExplorer.CurrentFolder
        CloseDatabase
        MsgBox "Done"
    End Sub
    Public Function AdrLeft(SLeft As String) As String
        'looking for characters before @ which can be a e-mail address - ,. , 0..9, A..Z, a..z
        leftchar = Len(SLeft)
        While (((AscW(Mid(SLeft, leftchar, 1)) &gt;= 45) And (AscW(Mid(SLeft, leftchar, 1)) = 48) And (AscW(Mid(SLeft, leftchar, 1)) = 65) And (AscW(Mid(SLeft, leftchar, 1)) = 97) And (AscW(Mid(SLeft, leftchar, 1))  1)
           leftchar = leftchar - 1
        Wend
        AdrLeft = Right(SLeft, Len(SLeft) - leftchar)
    End Function
    Public Function AdrRight(SRight As String) As String
        'looking for characters after @ which can be a e-mail address - ,. , 0..9, A..Z, a..z
        RightChar = 1
        While (((AscW(Mid(SRight, RightChar, 1)) &gt;= 45) And (AscW(Mid(SRight, RightChar, 1)) = 48) And (AscW(Mid(SRight, RightChar, 1)) = 65) And (AscW(Mid(SRight, RightChar, 1)) = 97) And (AscW(Mid(SRight, RightChar, 1)) &lt;= 122))) And (RightChar  1 Then
            AtLeft = AdrLeft(Left(fString, AtPos - 1))
            If AtPos  0) Then WriteToDatabase MailAddress, "", ""
            FindAddress (Right(fString, Len(fString) - AtPos - Len(AtRight)))
        End If
    End Sub
    
    
    Sub ProcessFolder(olkFld As Outlook.Folder)
        Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.Recipient, intIdx As Integer
        Dim oBody As String, oSubject As String
           
        
        For Each olkItm In olkFld.Items
            DoEvents
            Select Case olkItm.Class
                Case olMail, olAppointment
                    WriteToDatabase olkItm.SenderEmailAddress, olkItm.SenderName
                    For Each olkRcp In olkItm.Recipients
                        WriteToDatabase olkRcp.AddressEntry.Address
                    Next
                Case olContact
                    If olkItm.Email1Address  "" Then WriteToDatabase olkItm.Email1Address
                    If olkItm.Email2Address  "" Then WriteToDatabase olkItm.Email2Address
                    If olkItm.Email3Address  "" Then WriteToDatabase olkItm.Email3Address
                Case olDistList
                    For intIdx = 1 To olkItm.MemberCount
                        WriteToDatabase olkItm.GetMember(intIdx).AddressEntry.Address, olkItm.GetMember(intIdx).AddressEntry.Name
                    Next
            End Select
            oSubject = olkItm.Subject
            oBody = olkItm.Body
            FindAddress (oBody)
        Next
        For Each olkSubFld In olkFld.Folders
            ProcessFolder olkSubFld
            DoEvents
        Next
        Set olkItm = Nothing
        Set olkSubFld = Nothing
        Set olkRcp = Nothing
    End Sub
    
    Sub InitDatabase()
        Const ForWriting = 2
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        'Edit the file name and path on the next line
        Set objFile = objFSO.CreateTextFile("C:\mail\Address Harvest.txt", ForWriting, True)
       
    End Sub
    
    Sub WriteToDatabase(strAddress As String, Optional First As String, Optional Last As String)
        Dim LineStr As String
        Rem extracking first and last name, if it is possible
        If (Not (Len(Last) &gt; 0)) And (Len(First) &gt; 0) Then
           If (InStr(First, ".") &gt; 0) Then
              Last = Right(First, Len(First) - InStr(First, "."))
              First = Left(First, InStr(First, ".") - 1)
           End If
           If (InStr(First, " ") &gt; 0) Then
              Last = Right(First, Len(First) - InStr(First, " "))
              First = Left(First, InStr(First, " ") - 1)
           End If
        If InStr(Last, "@") &gt; 0 Then Last = Left(Last, InStr(Last, "@") - 1)
        End If
        LineStr = strAddress + ";" + First + ";" + Last
        objFile.WriteLine LineStr
    End Sub
    
    Sub CloseDatabase()
        objFile.Close
        Set objFile = Nothing
        Set objFSO = Nothing
    End Sub
    
    Public Function IsDomain(TestDomain As String) As Boolean
    'chacking if the string after last dot is a valid top level domain name... list taken from http://data.iana.org/TLD/tlds-alpha-by-domain.txt
    Dim TLD(272) As String
    TLD(1) = "AC"
    TLD(2) = "AD"
    TLD(3) = "AE"
    TLD(4) = "AERO"
    TLD(5) = "AF"
    TLD(6) = "AG"
    TLD(7) = "AI"
    TLD(8) = "AL"
    TLD(9) = "AM"
    TLD(10) = "AN"
    TLD(11) = "AO"
    TLD(12) = "AQ"
    TLD(13) = "AR"
    TLD(14) = "ARPA"
    TLD(15) = "AS"
    TLD(16) = "ASIA"
    TLD(17) = "AT"
    TLD(18) = "AU"
    TLD(19) = "AW"
    TLD(20) = "AX"
    TLD(21) = "AZ"
    TLD(22) = "BA"
    TLD(23) = "BB"
    TLD(24) = "BD"
    TLD(25) = "BE"
    TLD(26) = "BF"
    TLD(27) = "BG"
    TLD(28) = "BH"
    TLD(29) = "BI"
    TLD(30) = "BIZ"
    TLD(31) = "BJ"
    TLD(32) = "BM"
    TLD(33) = "BN"
    TLD(34) = "BO"
    TLD(35) = "BR"
    TLD(36) = "BS"
    TLD(37) = "BT"
    TLD(38) = "BV"
    TLD(39) = "BW"
    TLD(40) = "BY"
    TLD(41) = "BZ"
    TLD(42) = "CA"
    TLD(43) = "CAT"
    TLD(44) = "CC"
    TLD(45) = "CD"
    TLD(46) = "CF"
    TLD(47) = "CG"
    TLD(48) = "CH"
    TLD(49) = "CI"
    TLD(50) = "CK"
    TLD(51) = "CL"
    TLD(52) = "CM"
    TLD(53) = "CN"
    TLD(54) = "CO"
    TLD(55) = "COM"
    TLD(56) = "COOP"
    TLD(57) = "CR"
    TLD(58) = "CU"
    TLD(59) = "CV"
    TLD(60) = "CW"
    TLD(61) = "CX"
    TLD(62) = "CY"
    TLD(63) = "CZ"
    TLD(64) = "DE"
    TLD(65) = "DJ"
    TLD(66) = "DK"
    TLD(67) = "DM"
    TLD(68) = "DO"
    TLD(69) = "DZ"
    TLD(70) = "EC"
    TLD(71) = "EDU"
    TLD(72) = "EE"
    TLD(73) = "EG"
    TLD(74) = "ER"
    TLD(75) = "ES"
    TLD(76) = "ET"
    TLD(77) = "EU"
    TLD(78) = "FI"
    TLD(79) = "FJ"
    TLD(80) = "FK"
    TLD(81) = "FM"
    TLD(82) = "FO"
    TLD(83) = "FR"
    TLD(84) = "GA"
    TLD(85) = "GB"
    TLD(86) = "GD"
    TLD(87) = "GE"
    TLD(88) = "GF"
    TLD(89) = "GG"
    TLD(90) = "GH"
    TLD(91) = "GI"
    TLD(92) = "GL"
    TLD(93) = "GM"
    TLD(94) = "GN"
    TLD(95) = "GOV"
    TLD(96) = "GP"
    TLD(97) = "GQ"
    TLD(98) = "GR"
    TLD(99) = "GS"
    TLD(100) = "GT"
    TLD(101) = "GU"
    TLD(102) = "GW"
    TLD(103) = "GY"
    TLD(104) = "HK"
    TLD(105) = "HM"
    TLD(106) = "HN"
    TLD(107) = "HR"
    TLD(108) = "HT"
    TLD(109) = "HU"
    TLD(110) = "ID"
    TLD(111) = "IE"
    TLD(112) = "IL"
    TLD(113) = "IM"
    TLD(114) = "IN"
    TLD(115) = "INFO"
    TLD(116) = "INT"
    TLD(117) = "IO"
    TLD(118) = "IQ"
    TLD(119) = "IR"
    TLD(120) = "IS"
    TLD(121) = "IT"
    TLD(122) = "JE"
    TLD(123) = "JM"
    TLD(124) = "JO"
    TLD(125) = "JOBS"
    TLD(126) = "JP"
    TLD(127) = "KE"
    TLD(128) = "KG"
    TLD(129) = "KH"
    TLD(130) = "KI"
    TLD(131) = "KM"
    TLD(132) = "KN"
    TLD(133) = "KP"
    TLD(134) = "KR"
    TLD(135) = "KW"
    TLD(136) = "KY"
    TLD(137) = "KZ"
    TLD(138) = "LA"
    TLD(139) = "LB"
    TLD(140) = "LC"
    TLD(141) = "LI"
    TLD(142) = "LK"
    TLD(143) = "LR"
    TLD(144) = "LS"
    TLD(145) = "LT"
    TLD(146) = "LU"
    TLD(147) = "LV"
    TLD(148) = "LY"
    TLD(149) = "MA"
    TLD(150) = "MC"
    TLD(151) = "MD"
    TLD(152) = "ME"
    TLD(153) = "MG"
    TLD(154) = "MH"
    TLD(155) = "MIL"
    TLD(156) = "MK"
    TLD(157) = "ML"
    TLD(158) = "MM"
    TLD(159) = "MN"
    TLD(160) = "MO"
    TLD(161) = "MOBI"
    TLD(162) = "MP"
    TLD(163) = "MQ"
    TLD(164) = "MR"
    TLD(165) = "MS"
    TLD(166) = "MT"
    TLD(167) = "MU"
    TLD(168) = "MUSEUM"
    TLD(169) = "MV"
    TLD(170) = "MW"
    TLD(171) = "MX"
    TLD(172) = "MY"
    TLD(173) = "MZ"
    TLD(174) = "NA"
    TLD(175) = "NAME"
    TLD(176) = "NC"
    TLD(177) = "NE"
    TLD(178) = "NET"
    TLD(179) = "NF"
    TLD(180) = "NG"
    TLD(181) = "NI"
    TLD(182) = "NL"
    TLD(183) = "NO"
    TLD(184) = "NP"
    TLD(185) = "NR"
    TLD(186) = "NU"
    TLD(187) = "NZ"
    TLD(188) = "OM"
    TLD(189) = "ORG"
    TLD(190) = "PA"
    TLD(191) = "PE"
    TLD(192) = "PF"
    TLD(193) = "PG"
    TLD(194) = "PH"
    TLD(195) = "PK"
    TLD(196) = "PL"
    TLD(197) = "PM"
    TLD(198) = "PN"
    TLD(199) = "POST"
    TLD(200) = "PR"
    TLD(201) = "PRO"
    TLD(202) = "PS"
    TLD(203) = "PT"
    TLD(204) = "PW"
    TLD(205) = "PY"
    TLD(206) = "QA"
    TLD(207) = "RE"
    TLD(208) = "RO"
    TLD(209) = "RS"
    TLD(210) = "RU"
    TLD(211) = "RW"
    TLD(212) = "SA"
    TLD(213) = "SB"
    TLD(214) = "SC"
    TLD(215) = "SD"
    TLD(216) = "SE"
    TLD(217) = "SG"
    TLD(218) = "SH"
    TLD(219) = "SI"
    TLD(220) = "SJ"
    TLD(221) = "SK"
    TLD(222) = "SL"
    TLD(223) = "SM"
    TLD(224) = "SN"
    TLD(225) = "SO"
    TLD(226) = "SR"
    TLD(227) = "ST"
    TLD(228) = "SU"
    TLD(229) = "SV"
    TLD(230) = "SX"
    TLD(231) = "SY"
    TLD(232) = "SZ"
    TLD(233) = "TC"
    TLD(234) = "TD"
    TLD(235) = "TEL"
    TLD(236) = "TF"
    TLD(237) = "TG"
    TLD(238) = "TH"
    TLD(239) = "TJ"
    TLD(240) = "TK"
    TLD(241) = "TL"
    TLD(242) = "TM"
    TLD(243) = "TN"
    TLD(244) = "TO"
    TLD(245) = "TP"
    TLD(246) = "TR"
    TLD(247) = "TRAVEL"
    TLD(248) = "TT"
    TLD(249) = "TV"
    TLD(250) = "TW"
    TLD(251) = "TZ"
    TLD(252) = "UA"
    TLD(253) = "UG"
    TLD(254) = "UK"
    TLD(255) = "US"
    TLD(256) = "UY"
    TLD(257) = "UZ"
    TLD(258) = "VA"
    TLD(259) = "VC"
    TLD(260) = "VE"
    TLD(261) = "VG"
    TLD(262) = "VI"
    TLD(263) = "VN"
    TLD(264) = "VU"
    TLD(265) = "WF"
    TLD(266) = "WS"
    TLD(267) = "XXX"
    TLD(268) = "YE"
    TLD(269) = "YT"
    TLD(270) = "ZA"
    TLD(271) = "ZM"
    TLD(272) = "ZW"
       
       TL = TestDomain
       IsDomain = False
    ' extract string after last dot to be chacket if it is top level domain
       While InStr(TL, ".")
         TL = Right(TL, Len(TL) - InStr(TL, "."))
       Wend
       TL = UCase(TL)
       IsD = False
       i = 0
    ' looking for top level domain in array
       While (i &lt; 272) And Not IsD
          i = i + 1
          If TLD(i) = TL Then IsD = True
       Wend
       If IsD Then IsDomain = True
       
    End Function
    
    • Hello! Not sure about the pasted code above, as it has many issues pasting into Outlook 2010. For example, “Public Function AdrRight” is defined as a function but is terminated with an “End Sub”. There are other syntax/function errors as well. It’s possibly due to a codepage difference. The original code posted at the top works fine with the exception of the directory path needing to change to fit your preferred save location.

    • Dale, you are right. There are a plenty mistakes, most of them caused by codepage difference. I will try to paste it again. I don’t know how end Sub shows at the end of function (!?).
      The script works fine for me in Outlook 2007. I made terrific job with it, mostly thanks to David for the first and core part of it, I

      Dim objFSO As Object, objFile As Object

      Sub HarvestAddresses()
      InitDatabase
      ProcessFolder Application.ActiveExplorer.CurrentFolder
      CloseDatabase
      MsgBox “Done”
      End Sub
      Public Function AdrLeft(SLeft As String) As String
      ‘looking for characters before @ which can be a e-mail address – ,. , 0..9, A..Z, a..z
      leftchar = Len(SLeft)
      While (((AscW(Mid(SLeft, leftchar, 1)) >= 45) And (AscW(Mid(SLeft, leftchar, 1)) = 48) And (AscW(Mid(SLeft, leftchar, 1)) = 65) And (AscW(Mid(SLeft, leftchar, 1)) = 97) And (AscW(Mid(SLeft, leftchar, 1)) 1)
      leftchar = leftchar – 1
      Wend
      AdrLeft = Right(SLeft, Len(SLeft) – leftchar)
      End Function
      Public Function AdrRight(SRight As String) As String
      ‘looking for characters after @ which can be a e-mail address – ,. , 0..9, A..Z, a..z
      RightChar = 1
      While (((AscW(Mid(SRight, RightChar, 1)) >= 45) And (AscW(Mid(SRight, RightChar, 1)) = 48) And (AscW(Mid(SRight, RightChar, 1)) = 65) And (AscW(Mid(SRight, RightChar, 1)) = 97) And (AscW(Mid(SRight, RightChar, 1)) <= 122))) And (RightChar 1 Then
      AtLeft = AdrLeft(Left(fString, AtPos – 1))
      If AtPos 0) Then WriteToDatabase MailAddress, “”, “”
      FindAddress (Right(fString, Len(fString) – AtPos – Len(AtRight)))
      End If
      End Sub

      Sub ProcessFolder(olkFld As Outlook.Folder)
      Dim olkItm As Object, olkSubFld As Outlook.Folder, olkRcp As Outlook.Recipient, intIdx As Integer
      Dim oBody As String, oSubject As String

      For Each olkItm In olkFld.Items
      DoEvents
      Select Case olkItm.Class
      Case olMail, olAppointment
      WriteToDatabase olkItm.SenderEmailAddress, olkItm.SenderName
      For Each olkRcp In olkItm.Recipients
      WriteToDatabase olkRcp.AddressEntry.Address
      Next
      Case olContact
      If olkItm.Email1Address “” Then WriteToDatabase olkItm.Email1Address
      If olkItm.Email2Address “” Then WriteToDatabase olkItm.Email2Address
      If olkItm.Email3Address “” Then WriteToDatabase olkItm.Email3Address
      Case olDistList
      For intIdx = 1 To olkItm.MemberCount
      WriteToDatabase olkItm.GetMember(intIdx).AddressEntry.Address, olkItm.GetMember(intIdx).AddressEntry.Name
      Next
      End Select
      oSubject = olkItm.Subject
      oBody = olkItm.Body
      FindAddress (oBody)
      Next
      For Each olkSubFld In olkFld.Folders
      ProcessFolder olkSubFld
      DoEvents
      Next
      Set olkItm = Nothing
      Set olkSubFld = Nothing
      Set olkRcp = Nothing
      End Sub

      Sub InitDatabase()
      Const ForWriting = 2
      Set objFSO = CreateObject(“Scripting.FileSystemObject”)
      ‘Edit the file name and path on the next line
      Set objFile = objFSO.CreateTextFile(“C:\mail\Address Harvest.txt”, ForWriting, True)

      End Sub

      Sub WriteToDatabase(strAddress As String, Optional First As String, Optional Last As String)
      Dim LineStr As String
      Rem extracking first and last name, if it is possible
      If (Not (Len(Last) > 0)) And (Len(First) > 0) Then
      If (InStr(First, “.”) > 0) Then
      Last = Right(First, Len(First) – InStr(First, “.”))
      First = Left(First, InStr(First, “.”) – 1)
      End If
      If (InStr(First, ” “) > 0) Then
      Last = Right(First, Len(First) – InStr(First, ” “))
      First = Left(First, InStr(First, ” “) – 1)
      End If
      If InStr(Last, “@”) > 0 Then Last = Left(Last, InStr(Last, “@”) – 1)
      End If
      LineStr = strAddress + “;” + First + “;” + Last
      objFile.WriteLine LineStr
      End Sub

      Sub CloseDatabase()
      objFile.Close
      Set objFile = Nothing
      Set objFSO = Nothing
      End Sub

      Public Function IsDomain(TestDomain As String) As Boolean
      ‘chacking if the string after last dot is a valid top level domain name… list taken from http://data.iana.org/TLD/tlds-alpha-by-domain.txt
      Dim TLD(272) As String
      TLD(1) = “AC”
      TLD(2) = “AD”
      TLD(3) = “AE”
      TLD(4) = “AERO”
      TLD(5) = “AF”
      TLD(6) = “AG”
      TLD(7) = “AI”
      TLD(8) = “AL”
      TLD(9) = “AM”
      TLD(10) = “AN”
      TLD(11) = “AO”
      TLD(12) = “AQ”
      TLD(13) = “AR”
      TLD(14) = “ARPA”
      TLD(15) = “AS”
      TLD(16) = “ASIA”
      TLD(17) = “AT”
      TLD(18) = “AU”
      TLD(19) = “AW”
      TLD(20) = “AX”
      TLD(21) = “AZ”
      TLD(22) = “BA”
      TLD(23) = “BB”
      TLD(24) = “BD”
      TLD(25) = “BE”
      TLD(26) = “BF”
      TLD(27) = “BG”
      TLD(28) = “BH”
      TLD(29) = “BI”
      TLD(30) = “BIZ”
      TLD(31) = “BJ”
      TLD(32) = “BM”
      TLD(33) = “BN”
      TLD(34) = “BO”
      TLD(35) = “BR”
      TLD(36) = “BS”
      TLD(37) = “BT”
      TLD(38) = “BV”
      TLD(39) = “BW”
      TLD(40) = “BY”
      TLD(41) = “BZ”
      TLD(42) = “CA”
      TLD(43) = “CAT”
      TLD(44) = “CC”
      TLD(45) = “CD”
      TLD(46) = “CF”
      TLD(47) = “CG”
      TLD(48) = “CH”
      TLD(49) = “CI”
      TLD(50) = “CK”
      TLD(51) = “CL”
      TLD(52) = “CM”
      TLD(53) = “CN”
      TLD(54) = “CO”
      TLD(55) = “COM”
      TLD(56) = “COOP”
      TLD(57) = “CR”
      TLD(58) = “CU”
      TLD(59) = “CV”
      TLD(60) = “CW”
      TLD(61) = “CX”
      TLD(62) = “CY”
      TLD(63) = “CZ”
      TLD(64) = “DE”
      TLD(65) = “DJ”
      TLD(66) = “DK”
      TLD(67) = “DM”
      TLD(68) = “DO”
      TLD(69) = “DZ”
      TLD(70) = “EC”
      TLD(71) = “EDU”
      TLD(72) = “EE”
      TLD(73) = “EG”
      TLD(74) = “ER”
      TLD(75) = “ES”
      TLD(76) = “ET”
      TLD(77) = “EU”
      TLD(78) = “FI”
      TLD(79) = “FJ”
      TLD(80) = “FK”
      TLD(81) = “FM”
      TLD(82) = “FO”
      TLD(83) = “FR”
      TLD(84) = “GA”
      TLD(85) = “GB”
      TLD(86) = “GD”
      TLD(87) = “GE”
      TLD(88) = “GF”
      TLD(89) = “GG”
      TLD(90) = “GH”
      TLD(91) = “GI”
      TLD(92) = “GL”
      TLD(93) = “GM”
      TLD(94) = “GN”
      TLD(95) = “GOV”
      TLD(96) = “GP”
      TLD(97) = “GQ”
      TLD(98) = “GR”
      TLD(99) = “GS”
      TLD(100) = “GT”
      TLD(101) = “GU”
      TLD(102) = “GW”
      TLD(103) = “GY”
      TLD(104) = “HK”
      TLD(105) = “HM”
      TLD(106) = “HN”
      TLD(107) = “HR”
      TLD(108) = “HT”
      TLD(109) = “HU”
      TLD(110) = “ID”
      TLD(111) = “IE”
      TLD(112) = “IL”
      TLD(113) = “IM”
      TLD(114) = “IN”
      TLD(115) = “INFO”
      TLD(116) = “INT”
      TLD(117) = “IO”
      TLD(118) = “IQ”
      TLD(119) = “IR”
      TLD(120) = “IS”
      TLD(121) = “IT”
      TLD(122) = “JE”
      TLD(123) = “JM”
      TLD(124) = “JO”
      TLD(125) = “JOBS”
      TLD(126) = “JP”
      TLD(127) = “KE”
      TLD(128) = “KG”
      TLD(129) = “KH”
      TLD(130) = “KI”
      TLD(131) = “KM”
      TLD(132) = “KN”
      TLD(133) = “KP”
      TLD(134) = “KR”
      TLD(135) = “KW”
      TLD(136) = “KY”
      TLD(137) = “KZ”
      TLD(138) = “LA”
      TLD(139) = “LB”
      TLD(140) = “LC”
      TLD(141) = “LI”
      TLD(142) = “LK”
      TLD(143) = “LR”
      TLD(144) = “LS”
      TLD(145) = “LT”
      TLD(146) = “LU”
      TLD(147) = “LV”
      TLD(148) = “LY”
      TLD(149) = “MA”
      TLD(150) = “MC”
      TLD(151) = “MD”
      TLD(152) = “ME”
      TLD(153) = “MG”
      TLD(154) = “MH”
      TLD(155) = “MIL”
      TLD(156) = “MK”
      TLD(157) = “ML”
      TLD(158) = “MM”
      TLD(159) = “MN”
      TLD(160) = “MO”
      TLD(161) = “MOBI”
      TLD(162) = “MP”
      TLD(163) = “MQ”
      TLD(164) = “MR”
      TLD(165) = “MS”
      TLD(166) = “MT”
      TLD(167) = “MU”
      TLD(168) = “MUSEUM”
      TLD(169) = “MV”
      TLD(170) = “MW”
      TLD(171) = “MX”
      TLD(172) = “MY”
      TLD(173) = “MZ”
      TLD(174) = “NA”
      TLD(175) = “NAME”
      TLD(176) = “NC”
      TLD(177) = “NE”
      TLD(178) = “NET”
      TLD(179) = “NF”
      TLD(180) = “NG”
      TLD(181) = “NI”
      TLD(182) = “NL”
      TLD(183) = “NO”
      TLD(184) = “NP”
      TLD(185) = “NR”
      TLD(186) = “NU”
      TLD(187) = “NZ”
      TLD(188) = “OM”
      TLD(189) = “ORG”
      TLD(190) = “PA”
      TLD(191) = “PE”
      TLD(192) = “PF”
      TLD(193) = “PG”
      TLD(194) = “PH”
      TLD(195) = “PK”
      TLD(196) = “PL”
      TLD(197) = “PM”
      TLD(198) = “PN”
      TLD(199) = “POST”
      TLD(200) = “PR”
      TLD(201) = “PRO”
      TLD(202) = “PS”
      TLD(203) = “PT”
      TLD(204) = “PW”
      TLD(205) = “PY”
      TLD(206) = “QA”
      TLD(207) = “RE”
      TLD(208) = “RO”
      TLD(209) = “RS”
      TLD(210) = “RU”
      TLD(211) = “RW”
      TLD(212) = “SA”
      TLD(213) = “SB”
      TLD(214) = “SC”
      TLD(215) = “SD”
      TLD(216) = “SE”
      TLD(217) = “SG”
      TLD(218) = “SH”
      TLD(219) = “SI”
      TLD(220) = “SJ”
      TLD(221) = “SK”
      TLD(222) = “SL”
      TLD(223) = “SM”
      TLD(224) = “SN”
      TLD(225) = “SO”
      TLD(226) = “SR”
      TLD(227) = “ST”
      TLD(228) = “SU”
      TLD(229) = “SV”
      TLD(230) = “SX”
      TLD(231) = “SY”
      TLD(232) = “SZ”
      TLD(233) = “TC”
      TLD(234) = “TD”
      TLD(235) = “TEL”
      TLD(236) = “TF”
      TLD(237) = “TG”
      TLD(238) = “TH”
      TLD(239) = “TJ”
      TLD(240) = “TK”
      TLD(241) = “TL”
      TLD(242) = “TM”
      TLD(243) = “TN”
      TLD(244) = “TO”
      TLD(245) = “TP”
      TLD(246) = “TR”
      TLD(247) = “TRAVEL”
      TLD(248) = “TT”
      TLD(249) = “TV”
      TLD(250) = “TW”
      TLD(251) = “TZ”
      TLD(252) = “UA”
      TLD(253) = “UG”
      TLD(254) = “UK”
      TLD(255) = “US”
      TLD(256) = “UY”
      TLD(257) = “UZ”
      TLD(258) = “VA”
      TLD(259) = “VC”
      TLD(260) = “VE”
      TLD(261) = “VG”
      TLD(262) = “VI”
      TLD(263) = “VN”
      TLD(264) = “VU”
      TLD(265) = “WF”
      TLD(266) = “WS”
      TLD(267) = “XXX”
      TLD(268) = “YE”
      TLD(269) = “YT”
      TLD(270) = “ZA”
      TLD(271) = “ZM”
      TLD(272) = “ZW”

      TL = TestDomain
      IsDomain = False
      ‘ extract string after last dot to be chacket if it is top level domain
      While InStr(TL, “.”)
      TL = Right(TL, Len(TL) – InStr(TL, “.”))
      Wend
      TL = UCase(TL)
      IsD = False
      i = 0
      ‘ looking for top level domain in array
      While (i < 272) And Not IsD
      i = i + 1
      If TLD(i) = TL Then IsD = True
      Wend
      If IsD Then IsDomain = True

      End Function

  19. Hi,
    Thanks for your macro!
    However, there’s a bug (well, maybe I did a mistake using it!)
    When I run the macro, there’s a dialog bow saying there’s a bug, & it is located at the line:
    Set objFile = objFSO.OpenTextFile(“D:\AddressHarvest.txt”, ForWriting, True)

    (I changed the location & name of the file, but it still doesn’t work :/)

    TIA,

    mk

    • Hi, mk.

      Yes, you found a bug. Two actually. OpenTextFile should have been CreateTextFile and I’d neglected to define a constant. I’ve fixed the code in the post. Please grab it again.

      Thanks for pointing out the bugs!

      Cheers!

    • Thanks a lot, David ! It’s fine, now. It could find 3000+ emails in a folder with 1000+ emails, most of them with big attachments?
      Some adresses don’t work as they were badly encoded in the messages, but that’s no big deal.

      Have a nice day:!

      mk

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s