Outlook E-Mail-Körper zu Excel

Question

Ich versuche, den Körper aller E-Mails in einem Ordner zu einer Excel-Datei ausgeben. Der Code unten ist, was ich bin mit:

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 

Das Problem ist, dass jede Nachricht in eine einzelne Zelle gesetzt wird, wenn ich jede Zeile in Outlook will eine eigene Linie in Excel zu haben, als ob ich kopieren war und Fügen Sie den Körper aus Outlook ein, um ihn manuell zu extrahieren (z. B. mit Strg + a, Strg + c, Strg + v).

Ich glaube, ich brauche Split(), um den Körper zu analysieren, aber ich habe keine Erfahrung mit dieser Funktion und kann nicht scheinen, um es zum Laufen zu bringen.

EDIT:

Ich konnte dies die unten durch die Verwendung lösen:

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 

Und

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 

Aber ich fühle mich nicht wie ich die Excel-Objekte referenzierte ganz richtig, wie diese Subs von Outlook VBA aufgerufen werden. Ich erhalte genau jedes Mal einen Fehler, wenn ich ihn ausführe. Das heißt, ich kann es einmal ausführen, es wird funktionieren, aber dann das zweite Mal wird es brechen, dann das dritte Mal wird es wieder funktionieren. Irgendwelche Vorschläge?

Answer 1

Ein Beispiel ist die 'SplitEmByLine' Funktion unten, ich habe die ReturnString und PrintArray Funktionen für einige Klarheit, aber diese können im Wesentlichen ignoriert werden.

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