Outlook Email Body to Excel - excel

Question

I am trying to have the body of all emails in a folder output to an excel file. The below code is what I am using:
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
strSheet = "Test.xlsm"
strPath = "C:user\Documents\Action Items\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Body
intColumnCounter = intColumnCounter + 1
Next itm
The issue is that each message is being put into a single cell when I want each line in outlook to have its own line in excel as if I were to copy and paste the body from outlook to excel manually (using ctrl+a, ctrl+c, ctrl+v, for example).
I feel like I need to use Split() to parse the body, but I've had no experience with that function and can't seem to get it to work.
EDIT:
I was able to solve this by using the below:
Sub SplitTextColumn()
Dim i As Long
Dim vA As Variant
[A1].Select
Range(Selection, Selection.End(xlDown)).Select
For i = 1 To Selection.Rows.Count
vA = Split(Selection.Resize(1).Offset(i - 1), vbLf)
Selection.Offset(i - 1).Resize(1, UBound(vA) + 1).Offset(, 1) = vA
Next
[A1].CurrentRegion.Offset(0, 1).Select
Selection.Copy
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
And
Sub MakeOneColumn()
Dim vaCells As Variant
Dim vOutput() As Variant
Dim i As Long, j As Long
Dim lRow As Long
If TypeName(Selection) = "Range" Then
If Selection.Count > 1 Then
If Selection.Count <= Selection.Parent.Rows.Count Then
vaCells = Selection.Value
ReDim vOutput(1 To UBound(vaCells, 1) * UBound(vaCells, 2), 1 To 1)
For j = LBound(vaCells, 2) To UBound(vaCells, 2)
For i = LBound(vaCells, 1) To UBound(vaCells, 1)
If Len(vaCells(i, j)) > 0 Then
lRow = lRow + 1
vOutput(lRow, 1) = vaCells(i, j)
End If
Next i
Next j
Selection.ClearContents
Selection.Cells(1).Resize(lRow).Value = vOutput
End If
End If
End If
Dim c As Range
Set rng = ActiveSheet.Range("A1:A5000")
For dblCounter = rng.Cells.Count To 1 Step -1
Set c = rng(dblCounter)
If c.Value Like "*MEADWESTVACO SUMMARY 856*" Then
c.EntireRow.Insert
End If
Next dblCounter
But I don't feel like I have the excel objects referenced quite right as those subs are being called from outlook VBA. I get an error exactly every other time I run it. That is to say I can run it once, it will work, but then the second time it will break, then the third it will work again. Any suggestions?

Answer 1

An example is the 'SplitEmByLine' function below, I left the ReturnString and PrintArray functions in for some clarity, but these can essentially be ignored.
Sub callSplitFunction()
Dim FileFull As String, a() As String, s As Long
FileFull = "C:\Users\thomas.preston\Desktop\ThisBookOfMine.txt"
'The below line calls function
a = SplitEmByLine(ReturnString(FileFull))
PrintArray a
End Sub
'*****The below function is what you need*****
Function SplitEmByLine(ByVal Body As String) As String()
Dim x As Variant
x = Split(Body, vbCrLf)
SplitEmByLine = x
End Function
Sub PrintArray(ByRef Arr() As String)
With Sheets("Sheet1")
For i = 0 To UBound(Arr)
.Cells(i + 1, 1).Value = Arr(i)
Next i
End With
End Sub
Function ReturnString(FilePath As String) As String
Dim TextFile As Integer
Dim FileContent As String
TextFile = FreeFile
Open FilePath For Input As TextFile
FileContent = Input(LOF(TextFile), TextFile)
Close TextFile
ReturnString = FileContent
End Function