Outlook电子邮件正文到Excel
我正在尝试将所有电子邮件的正文输出到一个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 问题是每个邮件都被放到一个单元格，当我希望Outlook中的每一行都在Excel中有自己的行，就像手动复制和粘贴从Outlook到Excel正文（使用Ctrl + a，Ctrl + c，ctrl + v，例如）。
我觉得我需要使用Split（）来分析正文，但是我没有经验与该function，似乎无法得到它的工作。
编辑：
我能够通过使用下面的解决scheme：
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
但我不觉得我有excel对象引用相当正确，因为从Outlook VBA调用这些潜艇。 每当我运行它时，我都会得到一个错误。 也就是说我可以运行一次，它会起作用，但是第二次将会中断，然后第三次再次运行。 有什么build议么？
一个例子是下面的“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