Mondays Mission: Macro to extract text from an email and paste it into an EXCEL Sheet

[maxwello]

Good Morning All,
I don’t know if this is possible but have hundreds of emails that I need to collect the data that is held in the body of the email. All the emails have the same text layout and the fields that I want to extract have the same headings. (See below example)

I would really appreciate any assistance or advice that you are able to provide.

Dear Sir,
Please find my account setup below.</SPAN>

User Name:Joe Blogs</SPAN>
User Firm:Blogs Inc</SPAN>
Email address: Joe.blogs@blogsinc.co.uk</SPAN>
Country:ENGLAND</SPAN>
UUID:1111111</SPAN>
User #:123456</SPAN>
Cust #:123456</SPAN>
Firm #:123456</SPAN>
Serial #:123456</SPAN>
Broker:ABAX</SPAN>
Application:Windows</SPAN>

 

[maxwello]

Hi Comfy,
This works perfectly but as I am starting to see from other forums there doesnt seem to be a decent way to make it more dynamic so if another user is using the macro they can use their signature without having to hard code the path. Dont suppose you have any other ideas?

 

[Comfy]

I will need to understand how you intend to use it.

You say another user, does this mean from their own PC and from their own Outlook? or

Everyone uses the same Outlook login and just attached different Signatures?

 

[maxwello]

The macro will be stored on a shared drive but run from various users computers and the emails will get generated from their personal outlook accounts and saved into their outlook draft folders.

 

[Comfy]

So the additional code will look for a signature stored on their personal outlook account called default.htm

Just make sure that all your users have saved their signature with the same name.

 

[Comfy]

Alternatively, we could loop through all the signatures stored in the Signature folder.

If there is only one use that one if there are multiple display a list to the user and ask them to select the most appropriate?

 

[maxwello]

I think its just going to be easier to use the default option.

Thanks again for your continued support

 

[s.ridd]

There is another way to insert data from Cells in Excel into an Outlook Item, this method even has the benefit of leaving the default signature of the account in that Item. Before I go on there is a downside and that is running it in Excel will likely cause you to get an Outlook Security Warning.

In Outlook 2007 and later the default editor is the WordEditor (this is also available in earlier versions of Outlook but may not be the default editor). This means that for all intents and purposes your Outlook Item is a Word Document, which means with VBA you can use most of the objects available in the Word Object Library. The Paste Method is one that we ar interested here. Rather than using Rob de Bruin's RangeToHTML code, you can simply copy an excel range and paste it into your Outlook Item. To do this, you can adapt the following code.

Sub RangeToEmailBody()

Dim OutApp As Outlook.Application
Dim outMI As Outlook.MailItem
Dim wdDoc As Word.Document


                                                                                                
    Set OutApp = Outlook.Application
    Set outMI = OutApp.CreateItem(olMailItem)
    
    With outMI
        .To = "test@test.com"
        .Subject = "Test"
        .Display
    End With
    
    Set wdDoc = outMI.GetInspector.WordEditor
    
    Selection.Copy
    With wdDoc.Application.Selection
        .TypeText "Dear Sir, " & vbNewLine & "Please can you provide sign-off for the below" & vbNewLine
        .Collapse Direction:=wdCollapseStart
        .PasteSpecial DataType:=wdPasteText
    End With


End Sub

Hope this helps

Simon

 

[jowoo]

Comfy, you are really good with vba.
I have been messing with the codes you posted but the only thing that I'm missing is when the pivot table is pasted into the email, I loose all the formatting. I tried Simon's code and it didn't work for me. Here's what my code looks like right now:

Sub Mail_Variance()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StringSubj As String

StringSubj = ActiveSheet.Range("d1") 'Filename

With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Range("D1").Select
Selection.ClearContents 'clear the contents of cell where formula for filename resides
Set rng = Nothing
Set rng = ActiveSheet.UsedRange
'You can also use a sheet name
'Set rng = Sheets("YourSheet").UsedRange
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "someone@email.com"
.CC = ""
.BCC = ""
.Subject = StringSubj
.HTMLBody = RangetoHTML(rng)

.display 'use .Display to show, use .Send to send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _
"align=left xublishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

 

[Comfy]

Comfy, you are really good with vba.

I wouldn't say that but Thank you.

When posting code please use the

 tags, it makes for much easier reading.

As you say the code Simon posted does not keep any formatting.  However the RangetoHTML function does (well it does when I setup an example and run it).

So I'm not sure where to start.  Could you upload a sample file (change any sensitive data) and message me the link so that I could take a look?

 

[s.ridd]

To keep all answers in the same place, I'll reply here.

When I ran your/Ron's code yesterday over a worksheet with a Pivot Table in it I wasn't losing any formatting, but I assumed that perhaps there was a situation I hadn't thought of. What formatting are you losing exactly and what version of Office are you using?

The code I posted in this thread would require you to set a reference to the Outlook and Word Object Libraries in order for it to run - that is the source of the error message you were getting. The code below will run without these references.

Sub RangeToEmailBody()
Dim outApp As Object, outMI As Object, wdDoc As Object
                                                                                                
    Set outApp = GetObject(, "Outlook.Application")
    Set outMI = outApp.CreateItem(0)
    
    With outMI
        .To = "[EMAIL="test@test.com"]test@test.com[/EMAIL]"
        .Subject = "Test"
        .Display
    End With
    
    Set wdDoc = outMI.GetInspector.WordEditor
    
    ActiveSheet.UsedRange.Copy
    wdDoc.Application.Selection.Paste
End Sub

Edit: Comfy beat me to the punch. My understanding is the code posted by jowoo wasn't retaining the formatting, although like you, I don't have any issues with formatting with that either. The code I originally posted will lose formatting because it is deliberately set to paste the text only, the one in this post won't