How to copy specific text from the body of the email?

mak
Option Explicit

Sub GetFromInbox()

Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox).Folders("impMail")
Set olItms = olFldr.Items

olItms.Sort "Subject"

For Each olMail In olItms
    If InStr(olMail.Subject, "SubjectoftheEmail") > 0 Then
        ThisWorkbook.Sheets("Fixings").Cells(2, 2).Value = olMail.Body

    End If
Next olMail

Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub

This code help me to download whole body of the email but I need specific bold text in cells. The email body is always as follows. The lines are always in the same order. All lines are always present. The all names in email could be known in advance.

This EMAIL IS ONLY FOR Internal use

Hi

@ABC4: please add the following detail in system (for 12-Jan-2019):

12345_ABC_MakOpt --- 264532154.78
12345_ABC_GAPFee --- 145626547.80

thanks

´ ----------------------------------------------------- 'get setup '-----------------------------------------------------

    Dim wb As Workbook
    Dim rngEmailSubject As Range
    Dim rngInstrumentName As Range
    Dim rngDate As Range
    Dim rngAmount As Range
    Dim arrFixing() As typFixing
    Dim rngValue As Range

    Dim rowIdx As Integer
    Dim ix As Integer
    Dim fixingDate As Date

    With wb.Sheets("FixingFromEmail")

        Set rngInstrumentName = .Range("instrument.name")
        Set rngDate = .Range("Date")
        Set rngAmount = .Range("Amount")

        rowIdx = rngInstrumentName.Row
        ix = 0

        Do While True

            rowIdx = rowIdx + 1
             If Not IsEmpty(.Cells(rowIdx, rngInstrumentName.Column).Value) _
        Then

                ix = ix + 1

                ReDim Preserve arrFixing(1 To ix)
                arrFixing(ix).InstrumentName = .Cells(rowIdx, rngInstrumentName.Column).Value
                arrFixing(ix).Date = .Cells(rowIdx, rngDate.Column).Value
                arrFixing(ix).Amount = .Cells(rowIdx, rngAmount.Column).Value


            Else
                Exit Do
            End If

        Loop

    End With´
Tony Dallimore

Your question is too vague for a specific answer. All I can offer is some guidance on the first stages.

You need to decide what is fixed and what is variable.

Is “@ABC4” fixed? Is “@ABC4: please add the following detail in system (for” fixed?

Are there always two data lines? Are there multiple data lines of which these are examples? Is the format of these lines:

Xxxxxxx space hyphen hyphen hyphen space amount 

I would start by splitting the text body into lines. Almost certainly the lines are broken by Carriage-Return Linefeed. To test:

Dim Count As Long

For Each olMail In olItms

  Debug.Print Replace(Replace(Mid$(olMailBody, 1, 200), vbCr, "{c}"), vbLf, "{l}" & vbLf)
  Count = Count + 1
  If Count >= 10 Then
    Exit For
  End If

Next olMail

The output will be something like ten (maximum) copies of:

@ABC4: please add the following detail in system (for 12-Jan-2019):{c}{l}
{c}{l}
12345_ABC_MakOpt --- 264532154.78{c}{l}
12345_ABC_GAPFee --- 145626547.80{c}{l}
Are the characters between lines “{c}{l}” or “{l}” or something else?

In the code below, replace vbCR & vbLf if necessary then run it:

Dim Count As Long
Dim InxL As Long
Dim Lines() As String

For Each olMail In olItms

  Lines = Split(olMail.Body, vbCR & vbLf)
  For InxL = 0 to UBound(Lines)
    Debug.Print InxL + 1 & "  " & Lines(InxL)
  Next
  Count = Count + 1
  If Count >= 10 Then
    Exit For
  End If

Next

The output will be something like ten (maximum) copies of:

0  
1  @ABC4: please add the following detail in system (for 12-Jan-2019):
2  
3  12345_ABC_MakOpt --- 264532154.78
4  12345_ABC_GAPFee --- 145626547.80
5 

Now you can see the text body as lines. Note: the first line is number 0. Is there never a blank line at the top? Is there always a blank line at the top? Does it vary? I am going to assume there is always a blank line at the top. The following code will need modification if that assumption is incorrect.

If line 1 is “xxxxxxxxxx date):” you could extract the date so:

Dim DateCrnt As Date
Dim Pos As Long

DateCrnt = CDate(Left$(Right$(Lines(1), 13), 11))

or

Pos = InStr(1, Lines(1), "(for ")
DateCrnt = CDate(Mid$(Lines(1), Pos + 5, 11))

Note: both these methods depend on the end of the line being just as you show in your example. If there is any variation you will need code that handles that variation.

You can now split the data lines using code like this:

Dim NameCrnt As String
Dim AmtCrnt As Double

For InxL = 3 To UBound(Lines)
  If Lines(InxL) <> "" Then
    Pos = InStr(1, Lines(InxL), " --- ")
    If Pos = 0 Then
      Debug.Assert False   ' Line not formatted as expected
    Else
      NameCrnt = Mid$(Lines(InxL), 1, Pos - 1)
      AmtCrnt = Mid$(Lines(InxL), Pos + 5)
    End If
    Debug.Print "Date="& DateCrnt & "    " & "Name=" & NameCrnt & "   " & "Amount=" & AmtCrnt
  End If
Next

Output is:

Date=12/01/2019    Name=12345_ABC_MakOpt   Amount=264532154.78
Date=12/01/2019    Name=12345_ABC_GAPFee   Amount=145626547.8

New section showing how to add data from email to worksheet

This is the second version of this section because the OP changed their mind about the format required.

The code below has been tested but with fake emails I created to look like the one in your question. So some debugging will probably be necessary.

I created a new workbook and a new worksheet named “Fixings” with the following headings:

Empty worksheet before macro run

After processing my fake emails, the worksheet looked like:

Worksheet after runs to add data from three daily emails

The sequence of rows is dependent on the sequence in which emails were found. You probably want newest first. Sorting the worksheet is outside the scope of this answer. Note: it is the column headings which tell the macro which values are to be recorded. If a new line was added to the email, add a new column heading and the value will be saved without changing the macro.

With one exception, I will not explain the VBA statements I have used because it is easy to search online for “VBA xxxxx” and find a specification for statement xxxxx. The exception is the use of two collections to hold pending data. The remaining explanations describe the reasons behind my approach.

There will be changes to the requirement although perhaps not for six or twelve months. For example, a manager will want a different heading or the columns in a different sequence. You cannot anticipate what changes will be required but you can prepare for changes. For example, at the top of my code I have:

Const ColFixDate As Long = 1
Const ColFixDataFirst As Long = 2
Const RowFixHead As Long = 1
Const RowFixDataFirst As Long = 2

I could have written Cells(Row, 1).Value = Date. This has two disadvantages: (1) if the date column is ever moved, you have to search through the code for statements that access it and (2) you have to remember what is in column 1 or 2 or 3 making your code harder to read. I avoid ever using literals for row or column numbers. The extra effort to type ColFixDataFirst instead of 2, quickly repays itself.

I notice in the code added to your question, you use named ranges to achieve the same effect. A problem with VBA is there are often several ways of achieving the same effect. I prefer constants but each of us must choose our own favourites.

Having worked in a department that processed many emails and workbooks, received from outsiders, that contained useful data, I can tell you that their formats change all the time. There will be an extra blank line or an existing one will be removed. There will be extra data or the existing data will be in a different sequence. The authors make changes they think will be helpful but rarely do anything useful like ask if receivers would like the change or even warn them of the change. The worst I ever saw was when two numeric columns were reversed and it was not noticed for months. Fortunately, I was not involved because it was a nightmare backing out the faulty data from our system and then importing the correct data. I check everything I can think of and refuse to process emails that are not exactly as I expect. The error messages are all written to the immediate window which is convenient during development. You may want to use MsgBox or write them to a file. If the email is processed successfully, it is not deleted; it is moved to a subfolder so it can be retrieved should it ever be needed again.

olMail is an Outlook constant. Do not use olMail or any other reserved word as a variable name.

I have used Session rather than a NameSpace. They are supposed to be equivalent but I once had a problem with a NameSpace that I could not diagnose so I no longer use them.

I do not sort the emails since your code does not take advantage of having the emails sorted. Perhaps you could take advantage of sorting by ReceivedTime but I can see potential problems that would not be easy to avoid.

I process the emails in reverse order because they are accessed by position. If email 5, say, is moved to another folder, the previous email 6 is now email 5 and the For loop skips it. If emails are processed in reverse order, you do not mind that email 6 is now email 5 because you have already processed that email.

If you do not set the NumberFormat of the cells holding dates or amounts, they will be displayed according to Microsoft’s default for your country. I have used my favourite display formats. Change to your favourite.

The code does not output anything to the worksheet until the entire email has been processed and the required data extracted. This means data from early data rows must be stored until all rows have been processed. I have used two Collections: PendingNames and PendingAmts. This is not how I would have stored the data in a macro I wrote for myself. My problem is that alternative approaches are more complicated or require more advanced VBA.

Come back with questions about anything else you do not understand.

Option Explicit
Sub GetFromInbox()

  Const ColFixDate As Long = 1
  Const ColFixName As Long = 2
  Const ColFixAmt As Long = 3
  Const RowFixDataFirst As Long = 2

  Dim AmtCrnt As Double
  Dim ColFixCrnt As Long
  Dim DateCrnt As Date
  Dim ErrorOnEmail As Boolean
  Dim Found As Boolean
  Dim InxItem As Long
  Dim InxLine As Long
  Dim InxPend As Long
  Dim Lines() As String
  Dim NameCrnt As String
  Dim olApp As New Outlook.Application
  Dim olFldrIn As Outlook.Folder
  Dim olFldrOut As Outlook.Folder
  Dim olMailCrnt As Outlook.MailItem
  Dim PendingAmts As Collection
  Dim PendingNames As Collection
  Dim Pos As Long
  Dim RowFixCrnt As Long
  Dim StateEmail As Long
  Dim TempStg As String
  Dim WshtFix As Worksheet

  Set WshtFix = ThisWorkbook.Worksheets("Fixings")
  With WshtFix
    RowFixCrnt = .Cells(Rows.Count, ColFixDate).End(xlUp).Row + 1
  End With

  Set olApp = New Outlook.Application
  Set olFldrIn = olApp.Session.GetDefaultFolder(olFolderInbox).Folders("impMail")
  Set olFldrOut = olFldrIn.Folders("Processed")

  For InxItem = olFldrIn.Items.Count To 1 Step -1

    If olFldrIn.Items(InxItem).Class = Outlook.olMail Then

      Set olMailCrnt = olFldrIn.Items(InxItem)

      If InStr(olMailCrnt.Subject, "SubjectoftheEmail") > 0 Then
        Lines = Split(olMailCrnt.Body, vbCr & vbLf)

        'For InxLine = 0 To UBound(Lines)
        '  Debug.Print InxLine + 1 & "  " & Lines(InxLine)
        'Next

        StateEmail = 0    ' Before "please add ..." line
        ErrorOnEmail = False
        Set PendingAmts = Nothing
        Set PendingNames = Nothing
        Set PendingAmts = New Collection
        Set PendingNames = New Collection

        For InxLine = 0 To UBound(Lines)
          NameCrnt = ""     ' Line is not a data line
          Lines(InxLine) = Trim(Lines(InxLine))  ' Remove any leading or trailing spaces

          ' Extract data from line
          If Lines(InxLine) <> "" Then
            If StateEmail = 0 Then
              If InStr(1, Lines(InxLine), "please add the ") = 0 Then
                Debug.Print "Error with email received " & olMailCrnt.ReceivedTime & vbLf & _
                            "  The first non-blank line is" & vbLf & _
                            "    " & Lines(InxLine) & vbLf & _
                            "  but I was expecting something like:" & vbLf & _
                            "    @ABC4: please add the following detail in system (for 13-Jan-2019):"
                ErrorOnEmail = True
                Exit For
              End If
              TempStg = Left$(Right$(Lines(InxLine), 13), 11)
              If Not IsDate(TempStg) Then
                Debug.Print "Error with email received " & olMailCrnt.ReceivedTime & vbLf & _
                            "  The value I extracted from the ""please add the ...""" & _
                            " line is """ & vbLf & "  " & TempStg & _
                            """ which I do not recognise as a date"
                ErrorOnEmail = True
                Exit For
              End If
              DateCrnt = CDate(TempStg)
              StateEmail = 1    ' After "please add ..." line
            ElseIf StateEmail = 1 Then
              If Lines(InxLine) = "" Then
                ' Ignore blank line
              ElseIf Lines(InxLine) = "thanks" Then
                ' No more data lines
                Exit For
              Else
                Pos = InStr(1, Lines(InxLine), " --- ")
                If Pos = 0 Then
                  Debug.Print "Error with email received " & olMailCrnt.ReceivedTime & vbLf & _
                              "  Data line: " & Lines(InxLine) & vbLf & _
                              "    does not contain ""---"" as required"
                  ErrorOnEmail = True
                  'Debug.Assert False
                  Exit For
                End If
                NameCrnt = Mid$(Lines(InxLine), 1, Pos - 1)
                TempStg = Mid$(Lines(InxLine), Pos + 5)
                If Not IsNumeric(TempStg) Then
                  Debug.Print "Error with email received " & olMailCrnt.ReceivedTime & vbLf & _
                              "  Data line:" & Lines(InxLine) & vbLf & _
                              "    value after ""---"" is not an amount"
                  ErrorOnEmail = True
                  'Debug.Assert False
                  Exit For
                End If
                AmtCrnt = CDbl(TempStg)
              End If
            End If  ' StateEmail
          End If ' Lines(InxLine) <> ""

          If ErrorOnEmail Then
            ' Ignore any remaining lines
            Exit For
          End If

          If NameCrnt <> "" Then
            ' Line was a data line without errors. Save until know entire email is error free
            PendingNames.Add NameCrnt
            PendingAmts.Add AmtCrnt
          End If

        Next InxLine

        If Not ErrorOnEmail Then
          ' Output pending rows now know entire email is error-free
          With WshtFix
            For InxPend = 1 To PendingNames.Count
              With .Cells(RowFixCrnt, ColFixDate)
                .Value = DateCrnt
                .NumberFormat = "d mmm yy"
              End With
              .Cells(RowFixCrnt, ColFixName).Value = PendingNames(InxPend)
              With .Cells(RowFixCrnt, ColFixAmt)
                .Value = PendingAmts(InxPend)
                .NumberFormat = "#,##0.00"
              End With
              RowFixCrnt = RowFixCrnt + 1
            Next
          End With
          ' Move fully processed email to folder Processed
          olMailCrnt.Move olFldrOut
        End If

      End If  ' InStr(olMailCrnt.Subject, "SubjectoftheEmail") > 0
    End If  ' olFldrIn.Items(InxItem).Class = Outlook.olMail

  Next InxItem

  Set olFldrIn = Nothing
  Set olFldrOut = Nothing
  olApp.Quit
  Set olApp = Nothing

End Sub

Collected from the Internet

Please contact [email protected] to delete if infringement.

edited at
0

Comments

0 comments
Login to comment

Related

How to get email body text and attachments using mimemessage class in java

Extract text string from undeliverable email body to excel

powershell to change existing email from text format to html body format

How to copy text contents in body to clipboard

How to copy range of cells as bitmaps in email body?

Extract Original Email Sender from Text Body Using Regex in R

How to move cursor after a specific word in email body

How to copy a specific text from html attribute to a PHP String?

How to get link from body of email - Selenium

How to extract href from a body email, in Perl?

Remove message body text from cell by keeping only email

How to copy specific text?

How to put multiple text boxes in an email body?

Fetch only text from email html body

Copy a specific text from lines using batch

How to Bold or color text on auto email body from Excel VBA

How to add a body text to a multipart email in python 2?

Copy text and image from Excel sheet as mail body to Outlook

wanted to copy specific text from the text file and keep it in one temp variable how to do that

Copy text from specific class in selenium

Copy range of cells from Excel as picture and add text in the email body

Get the first line of text from email body with Outlook VB

How to set email body text color with GmailApp

How can I remove specific elements from a body of text?

How can Javascript code be displayed as plain text in the body of an HTML email?

How do i extract text from email body using UiPath?

copy array list in to email body

How to pipe text for a Mutt email body, then edit the email interactively?

How to get the first dollar value from the text retrieved from the plain body from a Gmail email body