Importing tables from outlook emails into access

Hey All

I've been pulling my hair out since my boss asked me to find a way to do this, so any help is great appreciated.

What I have to do is find a way to automatically update an access database with info from an outlook html message. Our client will send over an automated email with a list of numbers in an html table. At the minute we have to manually enter this info into access.

I've been googling all weekend and found a few pieces of code i was able to put together. When an email comes in I can move it to the right folder and run the vba script using rules&alerts. The script will export emails from the active folder into a spreadsheet. It is a hit and miss when it comes to tables. I ran it on my inbox and got tables exporting, but not the client tables I need. Everything else except them. I assume the problem is parsing the data, but I cannot figure out how to make it work with these specific emails.

After the info is in the spreadsheet I am going to run an access query (from outlook) to import the spreadsheet and run queries to update the data.

Code:

---

'On the next line edit the path to the spreadsheet you want to export to
Const WORKBOOK_PATH = "Q:\Clients\Beachbody\Campaigns\Beachbody\Data\email\test.xlsx"
'On the next line edit the name of the sheet you want to export to
Const SHEET_NAME = "Sheet1"
Const MACRO_NAME = "Export Messages to Excel (Rev 8)"
 
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) _
  As Long
Private Declare Function GlobalAlloc Lib "kernel32" ( _
  ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function SetClipboardData Lib "user32" ( _
  ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias _
  "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _
  As Long
Private Declare Function GlobalUnlock Lib "kernel32" ( _
  ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
  pDest As Any, pSource As Any, ByVal cbLength As Long)
Private Declare Function GetClipboardData Lib "user32" ( _
  ByVal wFormat As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" ( _
  ByVal lpData As Long) As Long
 
Private Const m_sDescription = _
                  "Version:1.0" & vbCrLf & _
                  "StartHTML:aaaaaaaaaa" & vbCrLf & _
                  "EndHTML:bbbbbbbbbb" & vbCrLf & _
                  "StartFragment:cccccccccc" & vbCrLf & _
                  "EndFragment:dddddddddd" & vbCrLf
                 
Private m_cfHTMLClipFormat As Long
 
Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intExp As Integer, _
        intVersion As Integer
    intVersion = GetOutlookVersion()
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
    Set excWks = excWkb.Worksheets(SHEET_NAME)
    excApp.Visible = True
    intRow = excWks.UsedRange.rows.Count + 0
    'Write messages to spreadsheet
    For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Add a row for each field in the message you want to export
            'excWks.Cells(intRow, 1) = olkMsg.Subject
            'excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
            'excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
            PutHTMLClipboard GetTable(olkMsg.HTMLBody)
            excWks.Range("D" & intRow).Select
            excWks.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
            intRow = intRow + 1
            intExp = intExp + 1
        End If
    Next
    Set olkMsg = Nothing
    excWkb.Close True
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intExp & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub
 
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function
 
Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function
 
Function SMTP2007(olkMsg As Outlook.MailItem) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function
 
Function GetTable(strBody As String) As String
    Dim objRegEx As Object, colMatches As Object, varMatch As Variant
    Set objRegEx = CreateObject("VBscript.RegExp")
    With objRegEx
        .IgnoreCase = True
        .Global = True
        .Pattern = "<table.*?>(.*?)</table>"
        Set colMatches = .Execute(strBody)
    End With
    For Each varMatch In colMatches
        GetTable = varMatch
    Next
    Set objRegEx = Nothing
    Set colMatches = Nothing
End Function
 
Function RegisterCF() As Long
  'Register the HTML clipboard format
  If (m_cfHTMLClipFormat = 0) Then
      m_cfHTMLClipFormat = RegisterClipboardFormat("HTML Format")
  End If
  RegisterCF = m_cfHTMLClipFormat
   
End Function
 
Public Sub PutHTMLClipboard(sHtmlFragment As String, _
  Optional sContextStart As String = "<html><head>", _
  Optional sContextEnd As String = "</body></html>")
   
  Dim sData As String
   
  If RegisterCF = 0 Then Exit Sub
   
  'Add the starting and ending tags for the HTML fragment
  'sContextStart = sContextStart & "<!--StartFragment -->"
  'sContextEnd = "<!--EndFragment -->" & sContextEnd
   
  'Build the HTML given the description, the fragment and the context.
  'And, replace the offset place holders in the description with values
  'for the offsets of StartHMTL, EndHTML, StartFragment and EndFragment.
  sData = m_sDescription & sContextStart & sHtmlFragment & sContextEnd
  sData = Replace(sData, "aaaaaaaaaa", _
                  Format(Len(m_sDescription), "0000000000"))
  sData = Replace(sData, "bbbbbbbbbb", Format(Len(sData), "0000000000"))
  sData = Replace(sData, "cccccccccc", Format(Len(m_sDescription & _
                  sContextStart), "0000000000"))
  sData = Replace(sData, "dddddddddd", Format(Len(m_sDescription & _
                  sContextStart & sHtmlFragment), "0000000000"))
 
  'Add the HTML code to the clipboard
  If CBool(OpenClipboard(0)) Then
   
      Dim hMemHandle As Long, lpData As Long
     
      hMemHandle = GlobalAlloc(0, Len(sData) + 10)
     
      If CBool(hMemHandle) Then
               
        lpData = GlobalLock(hMemHandle)
        If lpData <> 0 Then
           
            CopyMemory ByVal lpData, ByVal sData, Len(sData)
            GlobalUnlock hMemHandle
            EmptyClipboard
            SetClipboardData m_cfHTMLClipFormat, hMemHandle
                       
        End If
     
      End If
   
      Call CloseClipboard
  End If
 
End Sub

---

and the html emails

HTML Code:

---

<html>
<head>
<style>
.info {
        color: #467EAC;
        padding:0 0 0 5px;
        text-align:left;
}
.para {
        margin : 10px 0px 0px 0px;
}

.bPara {
        margin : 10px 0px 0px 0px;
        font-weight : bold;
}
.line{
        margin : 5px 0px 0px 0px;
}

.break{
        margin : 10px 0px 0px 0px;
}
table {
        border: 1px solid #ccc;
        width:100%;
}
tr {
        border: 0;
}
td, th {
        /*font: 11px verdana, arial, helvetica, sans-serif;*/
    line-height: 12px;
        padding: 5px 6px;
        text-align: left;
}
th {
  background-color: #EBEBEB;
  color: #666666;
  font-size: 12px;
  font-style: normal;
  font-weight: bold;
  line-height: 17px;
  margin-left: 10px;
  padding: 2px 10px 2px 6px !important;
}
.body{
        font-family: Helvetica,Arial,sans-serif;
        font-size: 12px;
        font-weight: normal;
        background-color:#fff;
}
.section{
        font-family: Helvetica,Arial,sans-serif;
        font-size: 16px;
        font-weight: normal;
        font-style:italic;       
        padding :10px 20px 10px 20px;
}
.section textarea{
        font-family: Helvetica,Arial,sans-serif;
        font-size: 12px;
        font-weight: normal;
}
.even {
  background: none repeat scroll 0 0 #F6F7F7;
  border: 1px solid #E2E2C8;
}
.odd {
  background: none repeat scroll 0 0 #FFFFFF;
}
.formButton {
  background: none repeat scroll 0 0 #F5F4F4;
  border-bottom: 3px solid #FFFFFF;
  border-radius: 0 0 0 0;
  border-top: 1px solid #E9E7E7;
  float: right;
  height: 40px;
  margin: 0;
  padding: 8px 5px 0 0;
  text-align: right;
  width: 100%;
}

.underline {
        text-decoration: underline;
}
</style>

</head>
<body>
        <div class="body" style="background-color:#FFFFFF !important;">
        <div class="bPara">
            Dear Call Center,
        </div>
        <div class="bPara">
            Client has expired the following Numbers with our Number Supplier.  Please update your system to reflect the expirations as dated below.
        </div>

        <div class="para">

                       

                                <div class="line">Product: <span class="info">Product</span></div>
                                <div class="line">Show: <span class="info">Show</span></div>
                                <div class="line">Creative Version: <span class="info">001</span></div>
                                <div class="line">Region: <span class="info">UK</span></div>
                                <div class="line">Language: <span class="info">English</span></div>
                                <div class="line">Media Sub-type: <span class="info">REGULAR</span></div>
                                <div class="line">Agency: <span class="info">Agency</span></div>
                                <div class="line">Product Code: <span class="info">Product Code</span></div>
                                <div class="line">Media Type: <span class="info">Media Type</span></div>
                                <div class="line">DNIS Group: <span class="info">DNIS Group</span></div>

                                <div class="para">
                                        <div class="line">Numbers Expired:</div>
                                        <div class="para">
                                                <table border="0" cellspacing="0" cellpadding="0" style="background-color:#FFFFFF !important;" >
                                                        <thead>
                                                        <tr >
                                                                <th>number</th>
                                                                <th>Start Date</th>
                                                                <th>End Date</th>
                                                        </tr>
                                                        </thead>
                                                       
                                                                <tr>
                                                                        <td>222222222222</td>
                                                                        <td>04/24/2012</td>
                                                                        <td>04/21/2013</td>
                                                                </tr>
                                                       
                                                                <tr>
                                                                        <td>33333333333</td>
                                                                        <td>04/24/2012</td>
                                                                        <td>04/21/2013</td>
                                                                </tr>
                                                       
                                                                <tr>
                                                                        <td>11111111111</td>
                                                                        <td>04/24/2012</td>
                                                                        <td>04/21/2013</td>
                                                                </tr>
                                                       
                                                                <tr>
                                                                        <td>44444444444</td>
                                                                        <td>04/24/2012</td>
                                                                        <td>04/21/2013</td>
                                                                </tr>
                                                       
                                                </table>
                                        </div>
                                </div>
                       
                        <div class="bPara">
                        Please confirm receipt of directives using a <span class="underline">direct reply to this email</span> once completed. If there are any questions, please contact the appropriate member(s) of the Clients Telemarketing team.
                </div>
        </div>
        <div class="break">
           
        <div>
                        Thank you,
                </div>
                <div>
                        Client
                </div>
       
        </div>
        </div>
</body>
</html>

---

Code to run access query:

Code:

---

Dim appAccess As Access.Application

Set appAccess = CreateObject("Access.Application")
appAccess.OpenCurrentDatabase "... my database path ..."
appAccess.DoCmd.RunSQL ("... my query ...")
appAccess.CloseCurrentDatabase
appAccess.Quit

---