• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 298
  • Last Modified:

Copy Table from Email Body to Excel Sheet and Keep Format

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
        GoTo ExitFunction
    End If
    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
        xlwb.Save
        xlwb.Close
        xlApp.Quit
    
    Set xlws = Nothing
    Set xlwb = Nothing
    Set xlApp = Nothing
ExitFunction:
    Set objMess = Nothing
    Set objItems = Nothing
    Set objFolder = Nothing
    Set objNameSpace = Nothing
    Set olApp = Nothing
End Function

Open in new window

0
rsburge
Asked:
rsburge
  • 8
  • 5
  • 5
  • +1
1 Solution
 
gowflowCommented:
Hi

I hv following observations

1) Polaris test is an empty file with sheets AL FL GA INKY MN MO OH
2) in what sheet should the data be imported ?
3) you mention that 1 email it import correctly I see in the file Polaris-what-it-should-be.xls 1 table is imported only where as both emails have several tables !!! so do not understand how it is working on 1 email.

Pls answer above questions so we can go further
gowflow
0
 
gowflowCommented:
Sorry for item 3) I just scrolled down and indeed it copied the whole table. Pls advise for itmes 1 and 2
gowflow
0
 
gowflowCommented:
Also you are importing everything into A1 of sheet AL is this what you want ??? or you want to import the emails one after the other in sheet AL pls specify
gowflow
0
Get your Conversational Ransomware Defense e‑book

This e-book gives you an insight into the ransomware threat and reviews the fundamentals of top-notch ransomware preparedness and recovery. To help you protect yourself and your organization. The initial infection may be inevitable, so the best protection is to be fully prepared.

 
Jeffrey CoachmanCommented:
One of the most popular ways of doing this is to copy the data then paste it into an Excel "Template".
The template will contain the formatting.

Or create a macro in Excel that does the formatting.
0
 
NorieCommented:
It looks like the body of these emails is actually HTML and not just text.

So perhaps you should look at HTMLBody and not Body.
0
 
NorieCommented:
Here's some code that gets the tables from  the HTML in the table.

It's pretty rough and still needs some work but it works with both messages.
Option Compare Database
Option Explicit

Public Sub PolarisEmails()
' Outlook declarations
Dim olApp As Outlook.Application
Dim objFolder As Outlook.Folder
Dim objNameSpace As Outlook.NameSpace
Dim objItems As Outlook.Items
Dim objMess As MailItem
Dim strFilter As String
Dim strSubject

    ' Excel declarations
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Const xlShiftDown = -4121

    ' general declarations
Dim strTxtFileName As String
Dim IE As Object
Dim doc As Object

    strFilter = "[Categories]=""Polaris-AL"""

    Set olApp = CreateObject("Outlook.Application")
    Set objNameSpace = olApp.GetNamespace("MAPI")
    Set objFolder = objNameSpace.GetDefaultFolder(6)

    Set objFolder = objFolder.Folders("Excel Stuff")

    objFolder.Items.Sort "[Received]", False

    Set objItems = objFolder.Items

    objItems.Sort "[Received]", True

    Set objMess = objItems.Find(strFilter)

    If objMess Is Nothing Then Exit Sub

    strSubject = objMess.Subject
    
    Set xlApp = CreateObject("Excel.Application")
    
    Set xlWB = xlApp.Workbooks.Add
    
    xlApp.DisplayAlerts = False

    Set xlWS = xlWB.Sheets(1)

    strTxtFileName = "C:\SampleEmail.html"

    Open strTxtFileName For Output As #1

    Write #1, objMess.HTMLBody

    Close #1

    Set IE = CreateObject("InternetExplorer.Application")

    IE.navigate strTxtFileName


    Set doc = IE.Document

    GetAllTables doc, xlWS

    xlWS.Range("A1").Resize(2).EntireRow.Insert xlShiftDown
    
    xlWS.Range("A1") = strSubject
    IE.Quit

    xlApp.Visible = True

    Set objMess = Nothing
    Set objItems = Nothing
    Set objFolder = Nothing
    Set objNameSpace = Nothing
    Set olApp = Nothing
End Sub


Sub GetAllTables(doc, ws)

    Dim rng As Object
    Dim tbl As Object
    Dim rw As Object
    Dim cl As Object
    Dim tabno As Long
    Dim nextrow As Long
    Dim I As Long

    For Each tbl In doc.getElementsByTagName("TABLE")

        tabno = tabno + 1

        nextrow = nextrow + 1

        Set rng = ws.Range("B" & nextrow)

        rng.Offset(, -1) = "Table " & tabno

        For Each rw In tbl.Rows

            For Each cl In rw.Cells
                rng.Value = cl.outerText
                Set rng = rng.Offset(, 1)
                I = I + 1
            Next cl

            nextrow = nextrow + 1

            Set rng = rng.Offset(1, -I)
            I = 0
        Next rw

    Next tbl

    ws.Cells.ClearFormats

End Sub

Open in new window

0
 
rsburgeAuthor Commented:
Hi!  Thank you for your help.  The answers to your questions...

1.  Polaris_TEST is basically a template... Once this is working for AL, I will be using variations of this code to pull tables from other emails into the other tabs and then ultimately the workbook will be saved with all the tabs filled.

2.  For purposes of this test, I am importing the data into AL.  I am only importing the data from one email into each tab, so it will always go into A1.  (I hope this makes sense)

I have not tried HTMLbody; honestly, I didn't know it was an option.

I will be out all day, but will test it when I get home.

Thank you!
0
 
gowflowCommented:
rsburge

Here it is pls check the attach file and advise if this is what your looking for.

Pls not my comments:
1) you mentioned that your code imported the first email but not the second its correct as you are not looping through all emails which this version does.
2) This version keeps the format web intact so you get data and formating also.
3) this version will import in sheet AL all the emails the first one will come in the last row used in sheet AL the second email will skip 2 blank rows after the last row and will paste the data there etc...
4) This versio has a dashboard where you will get a trace of what is happening
5) You will need to add reference to Microsoft Internet Controls to do so, load this file goto Developper menu and choose Visual Basic the from the menu tools choose Refrences and from the list locate Microsoft Internet Controls select it then press ok save the file close it and start it again.
6) LAst but not least maybe 1 email was imported for you cos it is labeled with the Catergory Polaris but the second isn't. You have to make sure all the emails that you want to import need to be in the Category Polaris.

Pls check and let me know your comments.

gowflow
importEmails---Final.xlsm
0
 
NorieCommented:
gowflow

You don't need any additional references, late-binding can be used.

That's what I did in the code I posted.
0
 
gowflowCommented:
True, but is asker want to learn some VBA properties then its would help. But the workbook posted has a refrence to Microsoft Internet COntrols and if it is not ticked then it would fault reason why I mentioned it. I could hv removed it but choose to keep it to help asker.
gowflow
0
 
NorieCommented:
Actually I don't think you really need Internet Explorer if you are using a web query.

You just need to save the HTMLBody from the email to a file.

The reason I used IE was because I didn't think of using a web query.:)
0
 
rsburgeAuthor Commented:
goflow...  Thank you for the code you posted.  I like the way it works; I do need to have each email go into a separate tab.  I also need to limit the import to the tables only, and exclude the forwarded by lines.

The sample code I posted is what I was using to test only...  Once I had something working, then I was going to incorporate looking for the other emails.

Each email will have a slightly different subject line; i.e. they will include "AL", "KY", "MN", ect (state abbreviations).  I need a tab for each state abbreviation; thus the multiple tabs in the test template I posted.

imnorie...  I also tried the code you posted; it works, however tables 1-4 and some of the others don't paste in the proper columns, rather they paste as one cell (see attached) polaris-test-imnorie-sample.xls
0
 
gowflowCommented:
pls give me the format of the subjext so I can have them go to the proper worksheet. As far as other lines we can remove these provided the tables are all the same format or the lines to remove are the same also I will need your help to adivse what you want to remove
gowflow
0
 
rsburgeAuthor Commented:
Thank you for all of your help!  
The format of the subject will vary.  I have a program, Automate Pro, that processes emails as they come in and it assigns the category to the emails.  This is why I started the code looking for the category.  The category and corresponding tab in the workbook are listed below.

As for deleting the rows, every row before the row with "Rates Effective" in column "M" should be deleted.  This will always be at the top of the table in each email.

Polaris-AL = tab AL
Polaris-FL = tab FL
Polaris-GA = tab GA
Polaris-IN = tab IN
Polaris-KY = tab KY
Polaris-MN = tab MN
Polaris-MO = tab MO
Polaris-OH = tab OH
0
 
gowflowCommented:
Hi
This version will import email in the coresponding category of the email and if the sheet is not created it will create it for you if the sheet exist it will place the data after the last existing row,It will also delete all unecessary rows prior to "Rates Effective" per email.

ie if in sheet AL youalready imported 5 emails it will look from the starting point of the email imported till it finds "Rates Effective" and if any lines in between it will delete them.

Pls feel free to check this version, by the way there is only the Dashboard so if your emails are properly Categorized like your previous thread it will create and import data.

gowflow
importEmails---Final.xlsm
0
 
rsburgeAuthor Commented:
Thank you for this new version...  I will test this tomorrow morning.
0
 
rsburgeAuthor Commented:
Thank you for all of your help!  This works beautifully for what I am trying to do.
0
 
gowflowCommented:
your welcome anytime
gowflow
0
 
NorieCommented:
Hey, no points for suggestion using HTMLBody and saving it as a file?

Only kidding.:)
0

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 8
  • 5
  • 5
  • +1
Tackle projects and never again get stuck behind a technical roadblock.
Join Now