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>

 

[Comfy]

Actually forget that, I have just create a random pivottable to test this on.

I have used a function written by Ron de Bruin Using VBA in Excel to Send Workbooks and Ranges Through E-Mail with Outlook (Part 2 of 2)

At the moment the email address is hard coded, where will this be picked up from?

Sub EmailPivot()


Dim OutApp As Object
Dim OutMail As Object
Dim ws As Worksheet
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim pi2 As PivotItem
Dim strPF As String
Dim strPI As String
Dim rng As Range


With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With




strPF = "User Firm"
Set ws = Sheets("Sheet9") 'You will need to add the Sheet name or you can change it to ActiveSheet
Set pt = ws.PivotTables(1)
Set pf = pt.PivotFields(strPF)
Set OutApp = CreateObject("Outlook.Application")
Set rng = Nothing


For Each pi In pf.PivotItems
    Set OutMail = OutApp.CreateItem(0)
        For Each pi2 In pf.PivotItems
            If pi2.Name <> pi.Name Then pi2.Visible = False
        Next pi2
    Set rng = pt.TableRange1


On Error Resume Next
    With OutMail
        .To = "an email address here"
        .CC = ""
        .BCC = ""
        .Subject = pi.Name & " - Enablement Request"
        .HTMLBody = "Dear Sir,<br>" & _
                    "Please can you provide sign-off for the below<br>" & _
                    RangetoHTML(rng)
        ' In place of the following statement, you can use ".Display" to
        ' display the e-mail message.
        .Send
    End With
On Error GoTo 0


Set OutMail = Nothing
pt.PivotCache.Refresh
pf.ClearAllFilters
Next pi


With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    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 workbook to receive the data.
    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 an .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 the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    ' Close TempWB.
    TempWB.Close savechanges:=False
 
    ' Delete the htm file.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[maxwello]

Hi Comfy,
Smashed it out the park again, this is great. The email address will be taken from the Salesperson column and then confirmed against our internal outlook address book using. There maybe multiple sales people assigned to one client so the email may need to be sent to multiple people. It would be great if the sales people can be populated checked to get their email addresses and then I need to verify them before continuing but not sure if that is possible.

 

[Comfy]

Hi Comfy,
Smashed it out the park again, this is great. The email address will be taken from the Salesperson column and then confirmed against our internal outlook address book using. There maybe multiple sales people assigned to one client so the email may need to be sent to multiple people. It would be great if the sales people can be populated checked to get their email addresses and then I need to verify them before continuing but not sure if that is possible.

I'll take a look at it today.

What will probably happen is that the names can be added to the email and rather than using .send we can use .display.

This will mean that you will have several emails open ready to send and then all you need to do is click "Check Names" amend any that you need to and then hit Send.

 

[maxwello]

That sounds perfect. Thanks again for your continued assistance.

 

[Comfy]

Here you go, give this a try:

Sub EmailPivot()


Dim OutApp As Object
Dim OutMail As Object
Dim ws As Worksheet
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim pi2 As PivotItem
Dim strPF As String
Dim strPI As String
Dim rng As Range
Dim Email As Range
Dim Emails As String


With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With




strPF = "User Firm"
Set ws = Sheets("Sheet9") 'You will need to add the Sheet name or you can change it to ActiveSheet
Set pt = ws.PivotTables(1)
Set pf = pt.PivotFields(strPF)
Set OutApp = CreateObject("Outlook.Application")
Set rng = Nothing


For Each pi In pf.PivotItems
    Set OutMail = OutApp.CreateItem(0)
        For Each pi2 In pf.PivotItems
            If pi2.Name <> pi.Name Then pi2.Visible = False
        Next pi2
    Set rng = pt.TableRange1
For Each Email In pt.PivotFields("Salesperson").DataRange
    If Email.Value <> "" Then Emails = Emails & Email.Value & ";"
Next Email
On Error Resume Next
    With OutMail
        .To = Emails
        .CC = ""
        .BCC = ""
        .Subject = pi.Name & " - Enablement Request"
        .HTMLBody = "Dear Sir,
" & _
                    "Please can you provide sign-off for the below
" & _
                    RangetoHTML(rng)
        ' In place of the following statement, you can use ".Send" to
        ' send the e-mail message.
        .display
    End With
On Error GoTo 0


Set OutMail = Nothing
pt.PivotCache.Refresh
pf.ClearAllFilters
Emails = ""
Next pi


With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    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 workbook to receive the data.
    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 an .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 the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    ' Close TempWB.
    TempWB.Close savechanges:=False
 
    ' Delete the htm file.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[Comfy]

I spotted a small error an have updated the code.

 

[maxwello]

Comfy, you really are a legend. Thanks you so much for all your help.

If there is a charity that you support I would happily make a donation on your behalf for all your help. Please let me know.

 

[Comfy]

Comfy, you really are a legend. Thanks you so much for all your help.

If there is a charity that you support I would happily make a donation on your behalf for all your help. Please let me know.

Haha! that's very kind. I'm just happy I could help.

 

[maxwello]

Hi Comfy,
The script is working perfectly the only thing that I ahve been trying to do is add the auto signature of the person sending the emails. so far I ahve manged to get the signature in but it looses all the formating and ends up looking weird and the email address is displayed like this | Email HYPERLINK "</SPAN>mailto:name.surname@job.com</SPAN>"Oliver.Maxwell@job.com is there any way that I can open a new email which has the auto signature and paste my html file with the text and the table above it instead of how it does it at the moemtn and pastes the info over the top? Hope that makes sense.</SPAN></SPAN>

 

[Comfy]

Hi Max,

Add your signature as normal in outlook.

The email Body should now read:

.HTMLBody = "Dear Sir,
" & _
                    "Please can you provide sign-off for the below
" & _
                    RangetoHTML(rng) & Add_Sig

and then add this code to the module:

Function Add_Sig() As String
Dim SigString As String


SigString = Environ("appdata") & _
     "\Microsoft\Signatures\Default.htm" 'amend this to the name that you give to your signature


If Dir(SigString) <> "" Then
        Add_Sig = GetBoiler(SigString)
    Else
        Add_Sig = ""
    End If
    
End Function
Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.ReadAll
    ts.Close
End Function