Hello - I need to copy a table from the body of a specific email and paste it into a specific sheet of an Excel workbook. I am running this code from an Access 2007 database.
I have written the following basic code and it does work on the sample1 email, but it only pastes the text, it does not keep the format which is what I really need. Also, this doesn't really work for the sample2 email.
Attached is the code, two sample emails, the blank workbook, and what I need the Excel to look like when the table is copied to the sheet.
I am including two sample emails because sometimes it comes over and it is just the table but sometimes it is forwarded so it has the forwarded by information before the table.
Polaris-what-it-should-be.xls email-sample1.msg email-sample2.msg Polaris-TEST.xls
Public Function PolarisEmails() As Boolean
'-----EXTRACT URL FROM EMAIL-----'
Dim olApp, objFolder, objNameSpace
Dim objItems, objMess As MailItem
strFilter = "[Categories]=""Polaris-AL"""
Set olApp = CreateObject("Outlook.Application")
Set objNameSpace = olApp.GetNamespace("MAPI")
Set objFolder = objNameSpace.GetDefaultFolder(6)
objFolder.Items.Sort "[Received]", False
Set objItems = objFolder.Items
objItems.Sort "[Received]", True
Set objMess = objItems.Find(strFilter)
If objMess Is Nothing Then
' MsgBox "No email found!", vbCritical
PolarisEmails = True
Set xlApp = CreateObject("Excel.Application")
Set xlwb = xlApp.Workbooks.Open("d:\aLXE-Pricing\Polaris\Polaris_TEST.xls")
xlApp.Visible = False
xlApp.DisplayAlerts = False
Set xlws = xlwb.Sheets("AL")
xlws.Range("A1") = objMess.body
Set xlws = Nothing
Set xlwb = Nothing
Set xlApp = Nothing
Set objMess = Nothing
Set objItems = Nothing
Set objFolder = Nothing
Set objNameSpace = Nothing
Set olApp = Nothing