none
--- SOLVED --- Exporting HTML Table data from Outlook into Excel RRS feed

  • Question

  • Hi All,

    I'm trying to automate a process to pull information from HTML tables in emails.

    At present the HTML is presented in a two column, multiple row table, an example of the code is below.

    <html><head>
    
    <link rel="stylesheet" type="text/css" href="/_layouts/Christie/Styles/global.css">
    </head>
    <body>
    <table cellpadding="2px" cellspacing="0">
    <tbody>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    Email</td>
    <td style="width: 600px; border: 1px solid black">test.case@example.com</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    </td>
    <td style="width: 600px; border: 1px solid black">EN</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    Company</td>
    <td style="width: 600px; border: 1px solid black">Example</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    Street</td>
    <td style="width: 600px; border: 1px solid black">Example</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    City</td>
    <td style="width: 600px; border: 1px solid black">Example</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    Country</td>
    <td style="width: 600px; border: 1px solid black">GB</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    State/Province</td>
    <td style="width: 600px; border: 1px solid black">Example</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    ZIP/Postal code</td>
    <td style="width: 600px; border: 1px solid black">01234</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    Phone</td>
    <td style="width: 600px; border: 1px solid black">01234567890</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    Company Phone</td>
    <td style="width: 600px; border: 1px solid black">01234567890</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    Fax</td>
    <td style="width: 600px; border: 1px solid black">01234567890</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    Website</td>
    <td style="width: 600px; border: 1px solid black"></td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    First Name</td>
    <td style="width: 600px; border: 1px solid black">Test</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    Last Name</td>
    <td style="width: 600px; border: 1px solid black">Case</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    Job Title</td>
    <td style="width: 600px; border: 1px solid black">AV Consultant</td>
    </tr>
    <tr>
    <td style="width: 300px; background-color: #CCCCCC; font-weight: bold; border: 1px solid black">
    Department</td>
    <td style="width: 600px; border: 1px solid black">AV Technology</td>
    </tr>
    </tbody>
    </table>
    </body>
    </html>
    

    I receive multiple of these emails per week and want to transpose this data into a spreadsheet with one row for each email.

    I'm also having an issue where my current code only collects from the bottom most email in the folder.

    My current VBA Code is below.

    Option Explicit
    Sub Extraction()
    
    'Point to the desired emails
    Const strMail As String = "wokingham.temp@christiedigital.com"
    Dim oApp As Outlook.Application
    Dim oMapi As Outlook.MAPIFolder
    Dim oMail As Outlook.MailItem
    Dim oItem As Outlook.MailItem
    Dim oFolder
    
    Dim rowNum As Long
    
    'Error Handling
    On Error Resume Next
    Set oApp = GetObject(, "OUTLOOK.APPLICATION")
        If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
    On Error GoTo 0
    
    'Get Email Items
    Dim i As Long
    Set oMapi = oApp.GetNamespace("mapi").Folders(strMail).Folders("inbox").Folders("Envoke requests - Chris")
    Set oFolder = oApp.ActiveExplorer.CurrentFolder
    Set oMail = oMapi.Items(oMapi.Items.Count)
    
    'For i = 1 To oFolder.Items.Count - 1
        
        'Get HTML Table from email object
        Dim oHTML As MSHTML.HTMLDocument: Set oHTML = New MSHTML.HTMLDocument
        Dim oElColl As MSHTML.IHTMLElementCollection
        With oHTML
            .Body.innerHTML = oMail.HTMLBody
            Set oElColl = .getElementsByTagName("table")
        End With
        
        
        'Import into Excel
        Dim x As Long, y As Long
        For x = 0 To oElColl(0).Rows.Length - 1
            For y = 0 To oElColl(0).Rows(x).Cells.Length - 1
                Sheet1.Range("A2").Offset(x, y).Value = oElColl(0).Rows(x).Cells(y).innerText
            Next y
        Next x
    'Next i
    
    Set oApp = Nothing
    Set oMapi = Nothing
    Set oMail = Nothing
    Set oHTML = Nothing
    Set oElColl = Nothing
    
    End Sub

    All help will be greatly appreciated.

    Chris


    • Edited by Rakow01 Tuesday, May 9, 2017 12:11 PM
    Thursday, May 4, 2017 3:37 PM

Answers

  • Try...

    Option Explicit
    Sub Extraction()
    
    'Point to the desired emails
    Const strMail As String = "wokingham.temp@christiedigital.com"
    Dim oApp As Outlook.Application
    Dim oFolder As Outlook.Folder
    
    'Error Handling
    On Error Resume Next
    Set oApp = GetObject(, "Outlook.Application")
        If (oApp Is Nothing) Then Set oApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    
    'Get Folder
    Set oFolder = oApp.GetNamespace("mapi").Folders(strMail).Folders("inbox").Folders("Envoke requests - Chris")
    
    'Iterate through emails
    Dim oHTML As New MSHTML.HTMLDocument
    Dim oElColl As MSHTML.IHTMLElementCollection
    Dim NextRow As Long, i As Long, x As Long
    NextRow = 2
    For i = 1 To oFolder.Items.Count
        
        'Get HTML Table from email object
        With oHTML
            .Body.innerHTML = oFolder.Items(i).HTMLBody
            Set oElColl = .getElementsByTagName("table")
        End With
        
        'Import into Excel
        For x = 0 To oElColl(0).Rows.Length - 1
            Sheet1.Cells(NextRow, x + 1).Value = oElColl(0).Rows(x).Cells(1).innerText
        Next x
        
        NextRow = NextRow + 1
        
        Set oHTML = Nothing
        
    Next i
    
    Set oApp = Nothing
    Set oFolder = Nothing
    Set oHTML = Nothing
    Set oElColl = Nothing
    
    End Sub


    For the current folder, use the following instead...

    Set oFolder = oApp.ActiveExplorer.CurrentFolder

    To start importing the data at the first available row, use the following instead...

    NextRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1

    Hope this helps!


    Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"


    Friday, May 5, 2017 3:33 PM

All replies

  • Try...

    Option Explicit
    Sub Extraction()
    
    'Point to the desired emails
    Const strMail As String = "wokingham.temp@christiedigital.com"
    Dim oApp As Outlook.Application
    Dim oFolder As Outlook.Folder
    
    'Error Handling
    On Error Resume Next
    Set oApp = GetObject(, "Outlook.Application")
        If (oApp Is Nothing) Then Set oApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    
    'Get Folder
    Set oFolder = oApp.GetNamespace("mapi").Folders(strMail).Folders("inbox").Folders("Envoke requests - Chris")
    
    'Iterate through emails
    Dim oHTML As New MSHTML.HTMLDocument
    Dim oElColl As MSHTML.IHTMLElementCollection
    Dim NextRow As Long, i As Long, x As Long
    NextRow = 2
    For i = 1 To oFolder.Items.Count
        
        'Get HTML Table from email object
        With oHTML
            .Body.innerHTML = oFolder.Items(i).HTMLBody
            Set oElColl = .getElementsByTagName("table")
        End With
        
        'Import into Excel
        For x = 0 To oElColl(0).Rows.Length - 1
            Sheet1.Cells(NextRow, x + 1).Value = oElColl(0).Rows(x).Cells(1).innerText
        Next x
        
        NextRow = NextRow + 1
        
        Set oHTML = Nothing
        
    Next i
    
    Set oApp = Nothing
    Set oFolder = Nothing
    Set oHTML = Nothing
    Set oElColl = Nothing
    
    End Sub


    For the current folder, use the following instead...

    Set oFolder = oApp.ActiveExplorer.CurrentFolder

    To start importing the data at the first available row, use the following instead...

    NextRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1

    Hope this helps!


    Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"


    Friday, May 5, 2017 3:33 PM
  • Hi Dominic,

    Thanks for the help. The macro is now showing the following run time error
    "Object variable or With block variable not set"

    When I click debug the following line is highlighted

    For x = 0 To oElColl(0).Rows.Length - 1


    ## Follow-up, it turns out I was in the wrong folder on Outlook.

    This has now been solved.

    • Edited by Rakow01 Tuesday, May 9, 2017 12:11 PM
    Tuesday, May 9, 2017 12:09 PM