|
-
Apr 22nd, 2013, 06:58 AM
#1
Thread Starter
New Member
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
Last edited by jonny462; Apr 22nd, 2013 at 10:44 AM.
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|
Reply With Quote