export email from outlook - excel

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 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.

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