Option Explicit

Sub AddFolderToContacts()
Dim olFolder As Folder
Dim olExpl As Explorer
Dim olItem As MailItem
    Set olExpl = ActiveExplorer
    If Not olExpl Is Nothing Then
        Set olFolder = olExpl.CurrentFolder
        For Each olItem In olFolder.Items
            MsgBox olItem.Sender
            AddEmailToContacts olItem
        Next olItem
    End If
lbl_Exit:
    Set olItem = Nothing
    Set olExpl = Nothing
    Set olFolder = Nothing
    Exit Sub
End Sub

Sub AddEmailToContacts(objMail As Outlook.MailItem)
Dim strFind As String
Dim strAddress As String
Dim objNS As Outlook.NameSpace
Dim colContacts As Outlook.Items
Dim objContact As Outlook.ContactItem

Dim i As Integer
    On Error Resume Next

    ' get Contacts folder and its Items collection
    Set objNS = Application.GetNamespace("MAPI")
    Set colContacts = _
    objNS.GetDefaultFolder(olFolderContacts).Items

    ' process message recipients
    ' check to see if the recip is already in Contacts
    strAddress = objMail.SenderEmailAddress
    For i = 1 To 3
        strFind = "[Email" & i & "Address] = " & _
                  strAddress
        Set objContact = colContacts.Find(strFind)
        If Not objContact Is Nothing Then
            Exit For
        End If
    Next i

    ' if not, add it
    If objContact Is Nothing Then
        Set objContact = _
        Application.CreateItem(olContactItem)
        With objContact
            .FullName = objMail.SenderName
            .Email1Address = strAddress
            .Save
        End With
    End If
    Set objContact = Nothing

lbl_Exit:
    Set objNS = Nothing
    Set objContact = Nothing
    Set colContacts = Nothing
    Exit Sub
End Sub