Cfrgtkky

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 YourMailbox@gmail.com. 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.

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