Microsoft Office Forums - View Single Post

gmayor · 04-01-2020, 02:27 AM

You can do it with Outlook macros. Be warned that it will take a while to run if you have a lot of emails and/or sub folders. It has now been running on my own Outlook inbox with its many sub folders for around 15 minutes and has written thousands of addresses and is still adding addresses to the worksheet.

The following will write the sender name and sender e-mail address to an existing Excel workbook named in the macro, which must be pre-configured to have two columns each with a header row i.e. Name and Address.

Run the macro. Select Inbox and go for lunch.

Normally I would use a progress indicator for something like this but Outlook doesn't make it easy to present such an indicator in a forum post, so I would suggest having the worksheet opened in Excel so you can check on progress. I have trapped the obvious errors, but it is possible in thousands of e-mails to find some name/address with an obscure format that the process will baulk at.

There will inevitably be duplicates. You can use Excel to eliminate those later, or the process would be even slower.

Code:

Option Explicit

Sub GetAddresses()
'Graham Mayor - https://www.gmayor.com - Last updated - 01 Apr 2020 
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim SubFolder As Folder
Dim olNS As Outlook.NameSpace
    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    cFolders.Add olNS.PickFolder
    Do While cFolders.Count > 0
        Set olFolder = cFolders(1)
        cFolders.Remove 1
        ProcessFolder olFolder
        For Each SubFolder In olFolder.folders
            cFolders.Add SubFolder
            DoEvents
        Next SubFolder
    Loop
lbl_Exit:
    Set olFolder = Nothing
    Set SubFolder = Nothing
    Set cFolders = Nothing
    Set olNS = Nothing
    Exit Sub
err_Handler:
    GoTo lbl_Exit
End Sub

Private Sub ProcessFolder(iFolder As Folder)
'Graham Mayor - https://www.gmayor.com - Last updated - 01 Apr 2020 
Const strWB As String = "D:\Path\WorkbookName.xlsx"    'the path to the workbook (which must exist)
Const strSheet As String = "Sheet1"
Dim i As Long
Dim olItem As Object
Dim strSender As String
    If iFolder.items.Count > 0 Then
        For i = 1 To iFolder.items.Count
            Set olItem = iFolder.items(i)
            If TypeName(olItem) = "MailItem" Then
                strSender = Replace(olItem.sender, "'", "")
                strSender = Replace(strSender, Chr(34), "")
                WriteToWorksheet strWB, strsheet, strSender & "', '" & olItem.SenderEmailAddress
                DoEvents
            End If
        Next i
    End If
lbl_Exit:
    Set olItem = Nothing
    Exit Sub
End Sub

Public Function WriteToWorksheet(strWorkbook As String, _
                                 strRange As String, _
                                 strValues As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                       "Data Source=" & strWorkbook & ";" & _
                       "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
    strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
    Set CN = CreateObject("ADODB.Connection")
    Call CN.Open(ConnectionString)
    Call CN.Execute(strSQL, , 1 Or 128)
    CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function