Excel VBA提取outlook电子邮件正文-无法读取html内部文本电子邮件

Question

我正试图循环浏览一个名为Aberdeen的文件夹中的所有电子邮件。我的附加代码适用于文本电子邮件，但它不能读取HTML电子邮件。

我在代码中包含了从电子邮件主题中查找字符串的内容，以确定要运行的代码，因为我需要提取的每个代码都是不同的格式。

我还试图找到一种方法来提取空格前的第一个单词、第二个单词等，因为目前我的代码只是复制每一行文本。我希望在第一个单词中添加类似sheet2.range("A"&x).value = FindWord(abody(j),1)的内容。其中CCD_ 2是下一个空的行片材2。

提取的数据如下所示：

0C2007 ---------- HP-1373CMP B73G 13925 10925 11/25/2018 12:04:13 
0C204C ---------- HP-1539CMP B738 ----- ----- 11/25/2018 17:13:30 
0C208D CMP229 HP-1830CMP B738 37000 37000 11/25/2018 17:02:05 
0C2094 CMP236 HP-1833CMP B738 37000 37000 11/25/2018 11:06:56 
0C20A4 CMP235 HP-1836CMP B738 36000 36000 11/25/2018 21:19:35

代码：

Option Explicit
Sub EmailText()
Dim oHTML As MSHTML.HTMLDocument: Set oHTML = New MSHTML.HTMLDocument
Dim ObjOutlook As Object
Dim MyNamespace As Object
Dim i As Integer
Dim j As Long
Dim abody() As String
Dim strSubject As String
Dim x
Set ObjOutlook = GetObject(, "Outlook.Application")        
Set MyNamespace = ObjOutlook.GetNamespace("MAPI")
On Error Resume Next
For i = 1 To MyNamespace.GetDefaultFolder(6).Folders("Aberdeen").Items.Count
strSubject = MyNamespace.GetDefaultFolder(6).Folders("Aberdeen").Items(i).Subject
If strSubject Like "*Berdeen*" Then GoTo Aberdeen
If strSubject Like "*KPGD*" Then GoTo KPGD
If strSubject Like "*Canada*" Then GoTo Canada
If strSubject Like "*Blandford*" Then GoTo Blandford
If strSubject Like "*Macap*" Then GoTo Macapa
If strSubject Like "*Netherlands*" Then GoTo Netherlands
GoTo notfound
Aberdeen: 'This email format is in html and I think it needs to get the code from html inner text
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("Aberdeen").Items(i).Body, vbCrLf)        
For j = 0 To UBound(abody)
If Len(abody(j)) > 60 And Len(abody(j)) < 68 Then Sheet1.Cells(650000, 1).End(xlUp).Offset(1, 0).Value = (abody(j))
Next
MyNamespace.GetDefaultFolder(6).Folders("Aberdeen").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("Aberdeen_Complete")
GoTo comp

KPGD:
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("Aberdeen").Items(i).Body, vbCrLf)
For j = 0 To UBound(abody)
If Len(abody(j)) > 60 And Len(abody(j)) < 68 Then Sheet1.Cells(650000, 1).End(xlUp).Offset(1, 0).Value = (abody(j))
Next
MyNamespace.GetDefaultFolder(6).Folders("Aberdeen").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("Aberdeen_Complete")
GoTo comp

Canada:
For j = 0 To UBound(abody)    
If Len(abody(j)) > 60 And Len(abody(j)) < 68 Then Sheet1.Cells(650000, 1).End(xlUp).Offset(1, 0).Value = (abody(j))
Next
MyNamespace.GetDefaultFolder(6).Folders("Aberdeen").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("Aberdeen_Complete")
GoTo comp

Blandford:
For j = 0 To UBound(abody) 
If Len(abody(j)) > 60 And Len(abody(j)) < 68 Then Sheet1.Cells(650000, 1).End(xlUp).Offset(1, 0).Value = (abody(j)) 
Next
MyNamespace.GetDefaultFolder(6).Folders("Aberdeen").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("Aberdeen_Complete")
GoTo comp

Macapa:
For j = 0 To UBound(abody)
If Len(abody(j)) > 80 Then Sheet1.Cells(650000, 1).End(xlUp).Offset(1, 0).Value = (abody(j)) 
Next
MyNamespace.GetDefaultFolder(6).Folders("Aberdeen").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("Aberdeen_Complete")

Netherlands:
For j = 0 To UBound(abody)
If Len(abody(j)) > 54 And Len(abody(j)) < 68 Then Sheet1.Cells(650000, 1).End(xlUp).Offset(1, 0).Value = (abody(j))   
Next
MyNamespace.GetDefaultFolder(6).Folders("Aberdeen").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("Aberdeen_Complete")
GoTo comp

notfound:
comp:
Next
Set ObjOutlook = Nothing
Set MyNamespace = Nothing
End Sub

Function FindWord(Source As String, Position As Integer)
Dim xcount
Dim arr() As String
arr = VBA.Split(Source, " ")
xcount = UBound(arr)
If xcount < 1 Or (Position - 1) > xcount Or Position < 0 Then
FindWord = ""
Else
FindWord = arr(Position - 1)
End If
End Function

Answer 1

我已经设法解决了如何使用下面的拆分选项代码来拆分字段。谢谢你看这个和你的评论。

KPGD:
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("Aberdeen").Items(i).Body, 
vbCrLf)
For j = 0 To UBound(abody)
If Len(abody(j)) > 60 And Len(abody(j)) < 68 Then
Sheet1.Cells(650000, 1).End(xlUp).Offset(1, 0).Value = (abody(j))
Sheet2.Cells(650000, 1).End(xlUp).Offset(1, 0).Value = Split(abody(j), " ")(0)
Sheet2.Cells(650000, 2).End(xlUp).Offset(1, 0).Value = Split(abody(j), " ")(1)
Sheet2.Cells(650000, 3).End(xlUp).Offset(1, 0).Value = Split(abody(j), " ")(2)
Sheet2.Cells(650000, 4).End(xlUp).Offset(1, 0).Value = Split(abody(j), " ")(3)
Sheet2.Cells(650000, 5).End(xlUp).Offset(1, 0).Value = Split(abody(j), " ")(6)
End If
Next
MyNamespace.GetDefaultFolder(6).Folders("Aberdeen").Items(i).Move 
MyNamespace.GetDefaultFolder(6).Folders("Aberdeen_Complete")
GoTo comp