扫描电子邮件正文并将某些行提取到Excel

Question

我需要设置一个Excel来扫描Outlook文件夹中的电子邮件（例如“测试”）。电子邮件是自动生成的，并包含一个所谓的表，该表实际上只是文本，用空格分隔。

每个邮件中的条目数不同。

示例：

仅提取一行信息的VBA代码确实可以工作，但是我找不到用于正确扫描剩余电子邮件正文的循环的工作方法。

Sub EmailExtract ()


Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namesapce
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim strBody As String
Dim strFind As String
Dim strColX, strColA, strColB, strColC, strColD, strColE As String
Dim xlSheet As Object
Dim itm As Object
Dim i As Integer
Dim sFilterStart As String
Dim sFilterEnd As String
Dim sExtract As String
Dim aExtract () As String
Dim aExtractItems () As String


Set OutloopApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder =         
OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("TEST")


i = 1 


On Error Resume Next
rCount = xlSheet.Range("A" & xlSheetl.Rows.Count).End(-4162).Row
rCount = rCount + 1


Worksheets("Sheet1").Range("A6:E250".ClearContents


For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("From_Date").Value Then


strBody = OutlookMail.Body 


strFind"368"
strColx = Mid(strBody, InStr(1, strBody, strFind, 1))
strColx = Left(strColx, 66)


stColA = Left(strColx, 8)
strColA = LTrim(strColA)
strColA = RTrim(strColA)


stColB = Left(strColx, 10, 10)
strColB = LTrim(strColB)
strColB = RTrim(strColB)


stColC = Left(strColx, 20, 20)
strColC = LTrim(strColC)
strColC = RTrim(strColC)


stColD = Left(strColx, 45, 10)
strColD = LTrim(strColD)
strColD = RTrim(strColD)


stColE = Left(strColx, 56, 11)
strColE = LTrim(strColE)
strColE = RTrim(strColE)


strFind = "Ship to"
strColF = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
strColF = Left(strColF, InStr(strColF, vbLf) -1)


Range("Release").Offset(i, 0).Value = stColA
Range("Schedule").Offset(i, 0).Value = stColB
Range("Part_Number").Offset(i, 0).Value = stColC
Range("Quantity").Offset(i, 0).Value = stColD
Range("First_req_Date").Offset(i, 0).Value = stColE
Range("Ship_To").Offset(i, 0).Value = stColF


i = i + 1
End If


Next OutlookMail


Set Folder = Nothing
Set OutlookNameSpace = Nothing
Set OutlookApp = Nothing


End Sub

结果表如下：

在一个列表中显示所有电子邮件的所有条目。

我正在寻找一种解决方案，该解决方案可以先扫描一个邮件，然后提取所有行。

我希望您拥有所有必要的信息，这是我第一次发布任何内容...

感谢您的帮助！

Kaspar