Outlook Email Body в Excel

Question

Я пытаюсь получить тело всех электронных писем в выводе папки в файл excel. Ниже код, что я использую:

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 

Проблема в том, что каждое сообщение кладется в одну ячейку, когда я хочу каждую строку в перспективе иметь свою собственную линию в Excel, как если бы я, чтобы скопировать и вставьте тело из Outlook, чтобы преуспеть вручную (используя ctrl + a, ctrl + c, ctrl + v, например).

Я чувствую, что мне нужно использовать Split() для синтаксического анализа тела, но я не имел опыта работы с этой функцией и не могу заставить его работать.

EDIT:

Я был в состоянии решить эту проблему с помощью ниже:

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 

И

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 

Но я не чувствую, что у меня есть объекты первенствовать ссылаются совершенно справедливо, поскольку эти подсистемы вызывают из Outlook VBA. Я получаю сообщение об ошибке в любое время, когда я его запускаю. То есть я могу запустить его один раз, он будет работать, но тогда второй раз он сломается, а затем третий будет работать снова. Какие-либо предложения?

Answer 1

Приведенный ниже пример функции «SplitEmByLine», я оставил функции ReturnString и PrintArray для некоторой ясности, но их можно по существу игнорировать.

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