Excel VBA для извлечения основной части электронной почты Outlook - невозможно прочитать html внутренние текстовые сообщения

Question

Я пытаюсь перебрать все электронные письма в папке с именем Aberdeen.Мой прикрепленный код работает с текстовыми электронными письмами, но он не читает электронные письма в формате HTML.

Я включил в код поиск строки из темы электронного письма, чтобы определить, какой код должен выполняться, поскольку каждый код, который мне требуется извлечьв другом формате.

Я также пытался найти способ извлечь первое слово перед пробелом, вторым словом и т. д., поскольку в настоящее время мой код просто копирует каждую строку текста.Я надеялся добавить что-то вроде sheet2.range("A"&x).value = FindWord(abody(j),1) для первого слова.остроумие x - следующая пустая строка листа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