IMPORT A TABLE FROM WITHIN AN EMAIL INTO EXCEL AND SAVE

[bee1]

Hi,
I receive about 25 mails daily each containing a table. The table is usually copied from excel and pasted into the body of the mail by the sender. I have to open each of these emails when it arrives, copy the excel table in the body of the message, paste into an excel file and save the excel file in a specified name format on our network drive. The table could be anywhere within the body of the email.
Question 1: Is there a VBA code that can help me perform this routine as the number of mails are increasing now? If there is please help me out. (My knowledeg of VBA is really limited please). I use Excel and Outlook 2010.

[gmayor]

This is relatively straightforward to achieve and can be done using a script as the messages arrive, or you can wait until they are in the inbox and batch process a selection. The larger macro (below) will do the former, the smaller one the latter.

What is not clear from your post is the file naming protocol that would allow the process to be fully automatic, and what you want to do about matching filenames that already exist in the target folder.




Option Explicit

Sub ProcessMessage()
Dim olItem As MailItem
For Each olItem In Application.ActiveExplorer.Selection
If olItem.Class = OlObjectClass.olMail Then
TableToExcel olItem
End If
Next olItem
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub


Sub TableToExcel(olItem As MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim oTable As Object

With olItem
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
If oRng.Tables.Count = 0 Then GoTo lbl_Exit
Set oTable = oRng.Tables(1)
oTable.Range.Copy
.Close 0
End With

On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
xlApp.Visible = True
On Error GoTo 0
Set xlWB = xlApp.workbooks.Add 'You might want to use a template here?
Set xlSheet = xlWB.Sheets(1)
xlSheet.Paste
'Save the workbook here
lbl_Exit:
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Set oTable = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set xlApp = Nothing
Exit Sub
End Sub

[bee1]

Thanks Graham for your really helpful post. The files are saved in the same folder everyday as Trade1, Trade2, Trade3 etc for as many workbooks as you receive in a day so that they don't get overwritten. At close of business, all the contents of that folder are copied into another dated folder so that the save location becomes empty, ready for the next day's files. The location I want to save to is "J:\TradeTickets\". Can you please ammend the script to reflect these? Also, where is the start of the smaller macro from your ealier post?

Thanks

[gmayor]

It will need additional functions to achieve that kind of naming. If the folder "J:\TradeTickets\" doesn't exist it will crash, leaving a hidden Excel application running, so make sure it is there and you have write access before running it. If you are going to move the files at the end of the day to a dated folder, why not simply save them in the dated folder in the first place? It wouldn't be much of a stretch to create the folder.

The smaller macro is Sub ProcessMessage() which runs ....
The script to attach to a rule is Sub TableToExcel(olItem As MailItem)



Option Explicit

Sub ProcessMessage()
Dim olItem As MailItem
For Each olItem In Application.ActiveExplorer.Selection
If olItem.Class = OlObjectClass.olMail Then
TableToExcel olItem
End If
Next olItem
Set olItem = Nothing
lbl_Exit:
MsgBox "Selected message(s) processed."
Exit Sub
End Sub

Sub TableToExcel(olItem As MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim oTable As Object
Dim strWorkBookName As String
Const strPath As String = "J:\TradeTickets\"
With olItem
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
If oRng.Tables.Count = 0 Then GoTo lbl_Exit
Set oTable = oRng.Tables(1)
oTable.Range.Copy
.Close 0
End With

On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
'xlApp.Visible = True
On Error GoTo 0
Set xlWB = xlApp.workbooks.Add 'You might want to use a template here?
Set xlSheet = xlWB.Sheets(1)
xlSheet.Paste
strWorkBookName = FileNameUnique(strPath, "Trade.xlsx", "xlsx")
xlWB.SaveAs strPath & strWorkBookName
xlWB.Close SaveChanges:=False
lbl_Exit:
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Set oTable = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set xlApp = Nothing
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & lngF
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

[bee1]

I thought it was better to keep the folder the same name as another process will depend on it. That way we won't have to be specifying folder for the next process. I have tested the copy table script and while it works perfectly if the table is the only content of the email, it fails if there is any other message in the body of the mail before the table appears. How can I fix this bit?

[gmayor]

The macro as written addresses the first table in the message.

Set oTable = oRng.Tables(1)
It will fail if there are other tables before the required table. It shouldn't matter is there is other text before the table.
The macro is annotated on my web site at http://www.gmayor.com/outlook_message_tables_to_excel.htm
where I have also included code to automatically create the dated folders.

[bee1]

Hi Graham,
I am now experiencing a problem which I didnt have before. Yesterday the script worked fine. But when I was about to close outlook I was prompted to save the VBA project which I did. Unfortunately since then, I haven't been able to get it to work again. Please take a look at the attached perhaps you can spot something I am doing wrong.
Many thanks.

[gmayor]

It is impossible to say what the problem is from your screen shots. I notice that the Option Explicit instruction from the top of the module appears to be missing, as is the ProcessMessage macro, with which you could test it. I take it that the other functions are present?