Fetch Mail Addresses from MS-Outlook

ms-outlook-fetch-mail.vba

Option Explicit
 
 
Sub MailFetchTest()
 
    Dim addresses() As String
    Dim ns As Outlook.NameSpace
    Dim cnt As Integer
   
    Set ns = GetNamespace("MAPI")
    Dim folder As Outlook.MAPIFolder
    Dim msgItem As MailItem
    Dim rcpt As Outlook.Recipient
    Dim pa As PropertyAccessor
    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    
    ReDim addresses(999)
   
    ' Inbox Mails
    Set folder = ns.GetDefaultFolder(olFolderInbox)
    cnt = 0
    For Each msgItem In folder.Items
        If IsInArray(msgItem.SenderEmailAddress, addresses) = False Then
            addresses(cnt) = msgItem.SenderEmailAddress
            cnt = cnt + 1
        End If
    Next msgItem
   
    ' Sent Mails
    Set folder = ns.GetDefaultFolder(olFolderSentMail)
    For Each msgItem In folder.Items
        For Each rcpt In msgItem.Recipients
            Set pa = rcpt.PropertyAccessor
            If IsInArray(pa.GetProperty(PR_SMTP_ADDRESS), addresses) = False Then
                addresses(cnt) = pa.GetProperty(PR_SMTP_ADDRESS)
                cnt = cnt + 1
            End If
        Next rcpt
    Next msgItem
   
    ReDim Preserve addresses(cnt)
  
    Debug.Print ("------------------------------------")
    Dim a As Variant
    For Each a In addresses
        If Not IsNull(a) And Not IsEmpty(a) Then
            Debug.Print a
        End If
    Next a
   
End Sub
 
Function IsInArray(val As Variant, arr As Variant) As Boolean
    Dim elm As Variant
    On Error GoTo ArrayError:
        For Each elm In arr
            If elm = val Then
                IsInArray = True
                Exit Function
            End If
        Next elm
ArrayError:
    IsInArray = False
End Function