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

问题是，当我希望outlook中的每一行在excel中都有自己的行时，每个消息都被放入一个单元格中，就像我要将body从outlook复制并粘贴到excel一样（使用ctrl + a ，ctrl + c，ctrl + v，例如）。

我觉得我需要使用Split（）来解析身体，但我没有使用过该功能的经验，而且似乎无法让它发挥作用。

修改

我能够通过以下方式解决这个问题：

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调用的。我每次运行它时都会出错。也就是说我可以运行一次，它会起作用，但第二次它会破坏，然后第三次它会再次运行。有什么建议吗？

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

Outlook电子邮件正文到Excel

1 个答案: