How to export e-mail body in two different cells? - excel

Question

I want to export e-mail data from a specific folder by a range of dates.
The macro exports the received date and the body of the email.
The objective is to search for certain data that comes from the extracted body and show them in other rows.
Due to the 32767 character limit that Excel has in a cell, the bodies of some emails are not being fully exported.
Is there a way to export the body in two rows instead of one to avoid the Excel limitation?
Other suggestions to accomplish this process are appreciated.
Sub ImportEmails()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Outlook.Namespace
Dim IFolder As Outlook.MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Set OutlookApp = New Outlook.Application
'Outlook connection
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set wb = ThisWorkbook
'Select the folder to export emails, depending on the user´s folder name you must change it
Set IFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Test")
Set ws = wb.Sheets("Imported")
i = 0
Application.ScreenUpdating = False
ws.Cells.Clear
'Create headers
ws.Range("A1").Value = "Date Time"
ws.Range("B1").Value = "Body"
'Condition to select the today date in case of blank and export the emails
If IsEmpty(Range("end_date").Value) = True Then
Range("end_date").Value = "=today()"
End If
'Exporting proccedure
For Each OutlookMail In IFolder.Items
'Date validation
If DateValue(OutlookMail.ReceivedTime) >= DateValue(Range("start_date")) And DateValue(OutlookMail.ReceivedTime) <= DateValue(Range("end_date")) Then
'Fill the worksheet cells with the emails
ws.Range("A2").Offset(i, 0).Value = OutlookMail.ReceivedTime
ws.Range("B2").Offset(i, 0).Value = OutlookMail.Body
i = i + 1
End If
Next OutlookMail
Application.ScreenUpdating = True
Set IFolder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
LRimpr = LastRow(ws)
Set rng = ws.Range("A2:B" & LRimpr)
'Sort the columns by newest to oldest using the worksheet last row
With rng
.Sort Key1:=.Cells(1), Order1:=xlDescending, _
Orientation:=xlTopToBottom, Header:=xlNo
End With
MsgBox "Emails are successfully imported", vbInformation, "Import complete"
ws.Activate
End Sub

Answer 1

If you would be happy exporting the email body in multiple cells in a single row then replace your line
ws.Range("B2").Offset(i, 0).Value = OutlookMail.Body
with
Const CHUNK_SIZE As Long = 32000
Dim segment As Long
segment = 0
Do While True
ws.Range("B2").Offset(i, segment).Value = Mid$(OutlookMail.Body, segment * CHUNK_SIZE + 1, CHUNK_SIZE)
segment = segment + 1
If segment * CHUNK_SIZE > Len(OutlookMail.Body) Then Exit Do
Loop
Adjust the value for CHUNK_SIZE to your requirements ... it controls the number of characters that will be put into each cell, with the last cell having the 'remaining' characters (or all the characters if the body has less characters than CHUNK_SIZE)

Answer 2

To split the body into cells in a column.
Option Explicit
Sub ImportEmails_SplitBody_MultipleRows()
' Reference Microsoft Outlook nn.n Object Library
Dim OutlookApp As Outlook.Application
Dim iFolder As Outlook.Folder
Dim iFolderItems As Outlook.Items
Dim j As Long
Dim OutlookItem As Object
Dim lenBody As Long
Dim maxLen As Long
Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Set OutlookApp = New Outlook.Application
' Select folder
Set iFolder = Session.GetDefaultFolder(olFolderInbox).Folders("Test")
' Sort items
Set iFolderItems = iFolder.Items
iFolderItems.Sort "[ReceivedTime]", True
Set wb = ThisWorkbook
Set ws = wb.Sheets("Imported")
i = 0
' Application is Excel. No impact on Outlook
'Application.ScreenUpdating = False
ws.Cells.Clear
'Create headers
ws.Range("A1").Value = "Date Time"
ws.Range("B1").Value = "Body"
'Condition to select today's date in case of blank
If IsEmpty(Range("end_date").Value) = True Then
Range("end_date").Value = "=today()"
End If
'Debug.Print Range("start_date")
'Debug.Print Range("end_date")
'Exporting procedure
maxLen = 32767
'Debug.Print " maxLen: " & maxLen
For j = 1 To iFolderItems.Count
'Date validation
If iFolderItems(j).Class = olMail Then
Set OutlookItem = iFolderItems(j)
'Debug.Print OutlookItem.Subject
If DateValue(OutlookItem.ReceivedTime) >= DateValue(Range("start_date")) And _
DateValue(OutlookItem.ReceivedTime) <= DateValue(Range("end_date")) Then
lenBody = Len(OutlookItem.Body)
Dim txt As String
txt = OutlookItem.Body
Dim lenTxt As Long
lenTxt = Len(txt)
Do Until lenTxt = 0
'Fill the worksheet cells with the emails
'Debug.Print " Len(txt): " & Len(txt)
If lenTxt > maxLen Then
ws.Range("A2").Offset(i, 0).Value = OutlookItem.ReceivedTime
ws.Range("B2").Offset(i, 0).Value = Left(txt, maxLen)
txt = Right(txt, Len(txt) - maxLen)
Else
ws.Range("A2").Offset(i, 0).Value = OutlookItem.ReceivedTime
ws.Range("B2").Offset(i, 0).Value = txt
txt = ""
End If
i = i + 1
lenTxt = Len(txt)
Loop
Set OutlookItem = Nothing
End If
End If
Next
Application.ScreenUpdating = True
Set iFolder = Nothing
Set iFolderItems = Nothing
Set OutlookApp = Nothing
MsgBox "Emails are successfully imported", vbInformation, "Import complete"
ws.Activate
End Sub