CAPTURING THE RESPONSE FROM HTML TABLE EMAIL BODY FROM OUTLOOK

CAPTURING THE RESPONSE FROM HTML TABLE EMAIL BODY FROM OUTLOOK

Public Sub GetFromInbox()

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFldr As Outlook.MAPIFolder
    Dim olItms As Outlook.Items
    Dim olMail As Variant
    Dim x As Long, y As Long
    Dim ResponseSheet As Worksheet
 
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
 
    ActiveSheet.AutoFilterMode = False
    '************ Getting Base data last row and column

    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFldr = olNS.PickFolder
    If olFldr = "Nothing" Then Exit Sub
    Set olItms = olFldr.Items
 
    olItms.Sort "RECEIVED", True
 
    For Each sht In ThisWorkbook.Sheets
        If sht.Name = "Responses" Then sht.Delete
    Next sht
    Set ResponseSheet = ThisWorkbook.Sheets.Add
    ActiveSheet.Name = "Responses"
 
    For Each olMail In olItms

        Dim oHTML As MSHTML.HTMLDocument
        Set oHTML = New MSHTML.HTMLDocument
        Dim oElColl As MSHTML.IHTMLElementCollection
        With oHTML
            .Body.innerHTML = olMail.HTMLBody
            Set oElColl = .getElementsByTagName("table")
        End With
     
        ResponseSheet.Activate
     
        Dim lastusedrow As Long
        lastusedrow = WorksheetFunction.CountA(Range("A:A"))
     
        If lastusedrow = 0 Then
        For x = 0 To 0
            For y = 0 To oElColl(0).Rows(x).Cells.Length - 1
                Cells(lastusedrow + 1, 1).Offset(x, y).Value = oElColl(0).Rows(x).Cells(y).innerText
            Next y
        Next x
        End If
     
        lastusedrow = WorksheetFunction.CountA(Range("A:A"))
     
        For x = 1 To oElColl(0).Rows.Length - 1
            For y = 0 To oElColl(0).Rows(x).Cells.Length - 1
                Cells(lastusedrow + 1, 1).Offset(x - 1, y).Value = oElColl(0).Rows(x).Cells(y).innerText
            Next y
        Next x
         
        Set oHTML = Nothing
        Set oElColl = Nothing
        ActiveSheet.AutoFilterMode = False
   
    Next olMail

    Set olFldr = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
End Sub