export email from outlook

Question

Could you advise please how to export emails from excel files? I have an excel files with column called emails - this is a list of emails.

How can VBA script check every email from excel file in outlook and export emails with subject, data, sender from these excel file to new excel file or new sheet in current excel. I have this script:

Const MACRO_NAME = "Export Messages to Excel (Rev 4)"

Sub ExportMessagesToExcelbyDate()
    Dim olkLst As Object, _
        olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        strFilename As String, _
        strDateRange As String, _
        arrTemp As Variant, _
        datStart As Date, _
        datEnd As Date
    strFilename = InputBox("Enter a filename  to save the exported messages to.", , MICRO_NAME)
    If strFilename <> "" Then
        strDateRange = InputBox("Enter the date range of the messages to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", MACRO_NAME, Date & " to " & Date)
        arrTemp = Split(strDateRange, "to")
        datStart = IIf(IsDate(arrTemp(0)), arrTemp(0), Date) & " 12:00am"
        datEnd = IIf(IsDate(arrTemp(1)), arrTemp(1), Date) & " 11:59pm"
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
        End With
        intRow = 2
        'Write messages to spreadsheet
        Set olkLst = Application.ActiveExplorer.CurrentFolder.Items.Restrict("[ReceivedTime] >= '" & Format(datStart, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
        For Each olkMsg In olkLst
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set olkLst = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, MICRO_NAME
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

But this script export only selected folder in outlook. What is the more important it should be exported from conversation history. For example in excel file there is mailbox [email protected]. Script should find all conversation history and emails with this person and export information from emails. Information such as Subject, sender, date. Also script should check all list emails from excel file, not one.

Thanks for advices.

Answer 1

Application.ActiveExplorer.CurrentFolder will get current select folder, If you want to get all folder, you could refer to the below code:

Option Explicit

Sub repopulate3()

Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olparentfolder As Outlook.Folder
Dim olMail As Object

Dim eFolder As Object
Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet

Dim iCounter As Long
Dim lrow As Long
Dim lastrow As Long

'Set wb = ActiveWorkbook
'Set ws = wb.Worksheets("vlookup")

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
    Set olApp = CreateObject("Outlook.Application")
End If

Set olNs = olApp.GetNamespace("MAPI")
Set olparentfolder = olNs.GetDefaultFolder(olFolderInbox)

'wb.Sheets("vlookup").range("A2:C500").ClearContents

'i think you want column E here, not L?
'lastrow = ThisWorkbook.Worksheets("vlookup").Cells(Rows.count, "E").End(xlUp).Row

ProcessFolder olparentfolder

ExitRoutine:

Set olparentfolder = Nothing
Set olNs = Nothing
Set olApp = Nothing

End Sub


Private Sub ProcessFolder(ByVal oParent As Outlook.Folder)

Dim olFolder As Outlook.Folder
Dim olMail As Object

Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long
Dim lastrow As Long

'Set wb = ActiveWorkbook
'Set ws = wb.Worksheets("vlookup")

'lastrow = ThisWorkbook.Worksheets("vlookup").Cells(Rows.count, "E").End(xlUp).Row

For i = oParent.Items.Count To 1 Step -1

    Debug.Print oParent
    If TypeOf oParent.Items(i) Is MailItem Then
        Set olMail = oParent.Items(i)

        Debug.Print " " & olMail.Subject
        Debug.Print " " & olMail.ReceivedTime
        Debug.Print " " & olMail.SenderEmailAddress
        Debug.Print

        'For iCounter = 2 To lastrow
            'If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then 'qualify the cell
                'With ws
                '   lrow = .range("A" & .Rows.count).End(xlUp).Row
                '   .range("C" & lrow + 1).Value = olMail.body
                '   .range("B" & lrow + 1).Value = olMail.ReceivedTime
                '   .range("A" & lrow + 1).Value = olMail.SenderEmailAddress
                'End With
            'End If
        'Next iCounter

    End If

Next i

If (oParent.Folders.Count > 0) Then
    For Each olFolder In oParent.Folders
        ProcessFolder olFolder
    Next
End If

End Sub

For more information, Please refer to the below link:

VBA code to loop through every folder and subfolder in Outlook