none
How to copy specific text from the body of the email? RRS feed

  • Question

  • 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 as follows.

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

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

    Monday, January 14, 2019 11:22 AM

Answers

  • Use regular expressions.  You only provide a few examples.  I created a pattern to match.  You may need to adjust. Is it an HTML email.  If so, you may have to look at HTML to see if any tags mess up match.  There are tons of tutorials on internet.  Example:

    Sub Extract3()
    
      Dim regEx As Object
      Dim s As String
      Dim pat As String
      Dim matches As Object
      Dim match As Object
      Dim subMatch As Variant
      
      pat = "(\d+_\S+ --- \d+.\d+)"
    
      s = "12345_ABC_MakOpt --- 264532154.78" & vbCrLf
      s = s & "12345_ABC_GAPFee --- 145626547.80" & vbCrLf
    
      Set regEx = CreateObject("vbscript.regexp")
      regEx.Global = True
      regEx.IgnoreCase = True
      regEx.Pattern = pat
      regEx.MultiLine = True
      Set matches = regEx.Execute(s)
      For Each match In matches
        If match.subMatches.Count > 0 Then
          For Each subMatch In match.subMatches
            Debug.Print subMatch '' look at immediate window
          Next subMatch
        End If
      Next match
    End Sub


    • Edited by mogulman52 Monday, January 14, 2019 2:03 PM
    • Marked as answer by Sajjad05 Friday, February 8, 2019 10:16 AM
    Monday, January 14, 2019 1:58 PM
  • I hve covered extracting data from similar messages several times in this forum and have produced web pages to assist. Seehttp://www.gmayor.com/extract_data_from_email.htm orhttp://www.gmayor.com/extract_email_data_addin.htm

    However for messages that are less similar you can access the message body as if it was a Word document using the Outlook WordEditor inspector. There are some provisos, especially the note at the top of the macro, or it won't work, but if you are familiar with Word VBA you may find it easier to use this method and manipulate the strings using Find and Replace e.g.

    Sub GetFromInbox()
    'This macro requires the code from the link below to open Outlook correctly
    'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
    Dim olApp As Object
    Dim olNs As Object
    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object
    Dim olFldr As Object
    Dim olItms As Object
    Dim olMail As Object
    Dim i As Long
    
        Set olApp = OutlookApp()
        Set olNs = olApp.GetNamespace("MAPI")
        Set olFldr = olNs.GetDefaultFolder(6).Folders("impMail")
        Set olItms = olFldr.Items
    
        olItms.Sort "Subject"
    
        For Each olMail In olItms
            If InStr(olMail.Subject, "SubjectoftheEmail") > 0 Then
                Set olInsp = olMail.GetInspector
                Set wdDoc = olInsp.WordEditor
                Set oRng = wdDoc.Range
                With oRng.Find
                    Do While .Execute("system (for ")
                        oRng.collapse 0
                        oRng.moveenduntil ")"
                        Exit Do
                    Loop
                End With
                ActiveWorkbook.Sheets("Fixings").Cells(2, 2) = oRng.Text
                Set oRng = wdDoc.Range
                With oRng.Find
                    Do While .Execute("ABC_MakOpt")
                        oRng.Start = oRng.Paragraphs(1).Range.Start
                        oRng.End = oRng.Paragraphs(1).Range.End - 1
                        Exit Do
                    Loop
                End With
                ActiveWorkbook.Sheets("Fixings").Cells(2, 3) = oRng.Text
    
                Set oRng = wdDoc.Range
                With oRng.Find
                    Do While .Execute("ABC_GAPFee")
                        oRng.Start = oRng.Paragraphs(1).Range.Start
                        oRng.End = oRng.Paragraphs(1).Range.End - 1
                        Exit Do
                    Loop
                End With
                ActiveWorkbook.Sheets("Fixings").Cells(2, 4) = oRng.Text
    
            End If
            DoEvents
        Next olMail
    
        Set olFldr = Nothing
        Set olNs = Nothing
        Set wdDoc = Nothing
        Set olInsp = Nothing
        Set oRng = Nothing
        Set olItms = Nothing
        Set olMail = Nothing
        Set olApp = Nothing
    End Sub
    

    Note that you will have to add code to increment the row between each message or each entry will overwrite the last.




      

    Graham Mayor - Word MVP
    www.gmayor.com

    • Marked as answer by Sajjad05 Friday, February 8, 2019 10:15 AM
    Wednesday, January 16, 2019 6:14 AM
  • OK that's not quite what you asked - but essentially the process is similar

    Option Explicit
    
    Sub GetFromInbox()
    'This macro requires the code from the link below to open Outlook correctly
    'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
    Dim olApp As Object
    Dim olNs As Object
    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object
    Dim olFldr As Object
    Dim olItms As Object
    Dim olMail As Object
    Dim i As Long
    Dim NextRow As Long
    Dim xlSheet As Worksheet
    Dim sInst As String, sVal As String
    Dim dDate As Date
    
        Set olApp = OutlookApp()
        Set olNs = olApp.GetNamespace("MAPI")
        Set olFldr = olNs.GetDefaultFolder(6).Folders("impMail")
        Set olItms = olFldr.Items
        Set xlSheet = ActiveWorkbook.Sheets("Fixings")
        olItms.Sort "Subject"
    
        For Each olMail In olItms
            If InStr(olMail.Subject, "SubjectoftheEmail") > 0 Then
                Set olInsp = olMail.GetInspector
                Set wdDoc = olInsp.WordEditor
                Set oRng = wdDoc.Range
                With oRng.Find
                    Do While .Execute("system (for ")
                        oRng.collapse 0
                        oRng.moveenduntil ")"
                        Exit Do
                    Loop
                End With
                dDate = CDate(oRng.Text)
                Set oRng = wdDoc.Range
                With oRng.Find
                    Do While .Execute(FindText:=" --- ")
                        NextRow = xlSheet.Cells(xlSheet.Rows.Count, "A").End(xlUp).Row + 1
                        oRng.Start = oRng.Paragraphs(1).Range.Start
                        oRng.End = oRng.Paragraphs(1).Range.End - 1
                        sInst = Trim(Left(oRng.Text, InStr(1, oRng.Text, " ---")))
                        sVal = Trim(Mid(oRng.Text, InStrRev(oRng.Text, " --- ") + 5))
                        
                        xlSheet.Cells(NextRow, 1) = sInst
                        xlSheet.Cells(NextRow, 2) = dDate
                        xlSheet.Cells(NextRow, 3) = sVal
    
                        oRng.collapse 0
                        DoEvents
                    Loop
                End With
            End If
            DoEvents
        Next olMail
    
        Set olFldr = Nothing
        Set olNs = Nothing
        Set wdDoc = Nothing
        Set olInsp = Nothing
        Set oRng = Nothing
        Set olItms = Nothing
        Set olMail = Nothing
        Set olApp = Nothing
        Set xlSheet = Nothing
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    • Marked as answer by Sajjad05 Friday, February 8, 2019 10:15 AM
    Friday, January 18, 2019 5:31 AM
  • Change

    Dim dDate As Date

    to

    Dim strDate As String

    Change

    dDate = CDate(oRng.Text)

    to

    strDate = oRng.Text

    Change

     xlSheet.Cells(NextRow, 2) = dDate

    to

     xlSheet.Cells(NextRow, 2) = strDate

    It shouldn't matter how many messages you need to process as long as they share the same format as the example you posted.


    Graham Mayor - Word MVP
    www.gmayor.com

    • Marked as answer by Sajjad05 Friday, February 8, 2019 10:15 AM
    Friday, January 18, 2019 1:45 PM
  • If you are using a store that is not the default store then you need to establish the store name and set the folder relative to that store. The following should list the store names available

    Sub a()
    Dim olNS As NameSpace
    Dim oStore As Store
        Set olNS = GetNamespace("MAPI")
        For Each oStore In olNS.Stores
    Debug.Print oStore
        Next
        Set oStore = Nothing
        Set olNS = Nothing
    End Sub
    

    Then you can use the appropriate store name in the code to process the required sub folder e.g.

    Sub b()
    Dim olNS As NameSpace
    Dim oStore As Store
    Dim olFldr As Folder
        Set olNS = GetNamespace("MAPI")
        For Each oStore In olNS.Stores
            If oStore = "StoreName" Then
                Set olFldr = oStore.GetRootFolder.folders("Inbox").folders("impMail")
                'do stuff with olFldr'
                Exit For
            End If
        Next
        Set oStore = Nothing
        Set olNS = Nothing
        Set olFldr = Nothing
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    • Marked as answer by Sajjad05 Friday, February 8, 2019 10:15 AM
    Tuesday, January 22, 2019 10:10 AM

All replies

  • Use regular expressions.  You only provide a few examples.  I created a pattern to match.  You may need to adjust. Is it an HTML email.  If so, you may have to look at HTML to see if any tags mess up match.  There are tons of tutorials on internet.  Example:

    Sub Extract3()
    
      Dim regEx As Object
      Dim s As String
      Dim pat As String
      Dim matches As Object
      Dim match As Object
      Dim subMatch As Variant
      
      pat = "(\d+_\S+ --- \d+.\d+)"
    
      s = "12345_ABC_MakOpt --- 264532154.78" & vbCrLf
      s = s & "12345_ABC_GAPFee --- 145626547.80" & vbCrLf
    
      Set regEx = CreateObject("vbscript.regexp")
      regEx.Global = True
      regEx.IgnoreCase = True
      regEx.Pattern = pat
      regEx.MultiLine = True
      Set matches = regEx.Execute(s)
      For Each match In matches
        If match.subMatches.Count > 0 Then
          For Each subMatch In match.subMatches
            Debug.Print subMatch '' look at immediate window
          Next subMatch
        End If
      Next match
    End Sub


    • Edited by mogulman52 Monday, January 14, 2019 2:03 PM
    • Marked as answer by Sajjad05 Friday, February 8, 2019 10:16 AM
    Monday, January 14, 2019 1:58 PM
  • @mogulman52 Thanks for your efforts but it doenst help me alot could you please explain your pattern more. What i need actually the date and names and values in different cells.
    Tuesday, January 15, 2019 2:26 PM
  • Regular Expressions (regex) are very powerful for extracting and replacing text.  There is no way to properly explain regex in this forum.  I recommend this free PDF.  It explains regex in detail.  I did a lot of this 12 years ago to extract info from a text report.  It took me a few weeks to learn enough to extract info.  There are a lot of sites where you can experiment with patterns.  I've used this free tool for over 15 years.
    Tuesday, January 15, 2019 3:41 PM
  • I hve covered extracting data from similar messages several times in this forum and have produced web pages to assist. Seehttp://www.gmayor.com/extract_data_from_email.htm orhttp://www.gmayor.com/extract_email_data_addin.htm

    However for messages that are less similar you can access the message body as if it was a Word document using the Outlook WordEditor inspector. There are some provisos, especially the note at the top of the macro, or it won't work, but if you are familiar with Word VBA you may find it easier to use this method and manipulate the strings using Find and Replace e.g.

    Sub GetFromInbox()
    'This macro requires the code from the link below to open Outlook correctly
    'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
    Dim olApp As Object
    Dim olNs As Object
    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object
    Dim olFldr As Object
    Dim olItms As Object
    Dim olMail As Object
    Dim i As Long
    
        Set olApp = OutlookApp()
        Set olNs = olApp.GetNamespace("MAPI")
        Set olFldr = olNs.GetDefaultFolder(6).Folders("impMail")
        Set olItms = olFldr.Items
    
        olItms.Sort "Subject"
    
        For Each olMail In olItms
            If InStr(olMail.Subject, "SubjectoftheEmail") > 0 Then
                Set olInsp = olMail.GetInspector
                Set wdDoc = olInsp.WordEditor
                Set oRng = wdDoc.Range
                With oRng.Find
                    Do While .Execute("system (for ")
                        oRng.collapse 0
                        oRng.moveenduntil ")"
                        Exit Do
                    Loop
                End With
                ActiveWorkbook.Sheets("Fixings").Cells(2, 2) = oRng.Text
                Set oRng = wdDoc.Range
                With oRng.Find
                    Do While .Execute("ABC_MakOpt")
                        oRng.Start = oRng.Paragraphs(1).Range.Start
                        oRng.End = oRng.Paragraphs(1).Range.End - 1
                        Exit Do
                    Loop
                End With
                ActiveWorkbook.Sheets("Fixings").Cells(2, 3) = oRng.Text
    
                Set oRng = wdDoc.Range
                With oRng.Find
                    Do While .Execute("ABC_GAPFee")
                        oRng.Start = oRng.Paragraphs(1).Range.Start
                        oRng.End = oRng.Paragraphs(1).Range.End - 1
                        Exit Do
                    Loop
                End With
                ActiveWorkbook.Sheets("Fixings").Cells(2, 4) = oRng.Text
    
            End If
            DoEvents
        Next olMail
    
        Set olFldr = Nothing
        Set olNs = Nothing
        Set wdDoc = Nothing
        Set olInsp = Nothing
        Set oRng = Nothing
        Set olItms = Nothing
        Set olMail = Nothing
        Set olApp = Nothing
    End Sub
    

    Note that you will have to add code to increment the row between each message or each entry will overwrite the last.




      

    Graham Mayor - Word MVP
    www.gmayor.com

    • Marked as answer by Sajjad05 Friday, February 8, 2019 10:15 AM
    Wednesday, January 16, 2019 6:14 AM
  • Thanks Graham Mayor for your help. But i have still a small issue i want to copy date from the first line and the instrument name and instrument value seperately in column. What i mean date from first row of the email and the names and values seperately in columns with out (---). My first column in sheet is instrument name second is Date and third is Amount. Would be happy if you helpe me further.

    Best Regards,

    Sajjad

    Thursday, January 17, 2019 2:17 PM
  • OK that's not quite what you asked - but essentially the process is similar

    Option Explicit
    
    Sub GetFromInbox()
    'This macro requires the code from the link below to open Outlook correctly
    'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
    Dim olApp As Object
    Dim olNs As Object
    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object
    Dim olFldr As Object
    Dim olItms As Object
    Dim olMail As Object
    Dim i As Long
    Dim NextRow As Long
    Dim xlSheet As Worksheet
    Dim sInst As String, sVal As String
    Dim dDate As Date
    
        Set olApp = OutlookApp()
        Set olNs = olApp.GetNamespace("MAPI")
        Set olFldr = olNs.GetDefaultFolder(6).Folders("impMail")
        Set olItms = olFldr.Items
        Set xlSheet = ActiveWorkbook.Sheets("Fixings")
        olItms.Sort "Subject"
    
        For Each olMail In olItms
            If InStr(olMail.Subject, "SubjectoftheEmail") > 0 Then
                Set olInsp = olMail.GetInspector
                Set wdDoc = olInsp.WordEditor
                Set oRng = wdDoc.Range
                With oRng.Find
                    Do While .Execute("system (for ")
                        oRng.collapse 0
                        oRng.moveenduntil ")"
                        Exit Do
                    Loop
                End With
                dDate = CDate(oRng.Text)
                Set oRng = wdDoc.Range
                With oRng.Find
                    Do While .Execute(FindText:=" --- ")
                        NextRow = xlSheet.Cells(xlSheet.Rows.Count, "A").End(xlUp).Row + 1
                        oRng.Start = oRng.Paragraphs(1).Range.Start
                        oRng.End = oRng.Paragraphs(1).Range.End - 1
                        sInst = Trim(Left(oRng.Text, InStr(1, oRng.Text, " ---")))
                        sVal = Trim(Mid(oRng.Text, InStrRev(oRng.Text, " --- ") + 5))
                        
                        xlSheet.Cells(NextRow, 1) = sInst
                        xlSheet.Cells(NextRow, 2) = dDate
                        xlSheet.Cells(NextRow, 3) = sVal
    
                        oRng.collapse 0
                        DoEvents
                    Loop
                End With
            End If
            DoEvents
        Next olMail
    
        Set olFldr = Nothing
        Set olNs = Nothing
        Set wdDoc = Nothing
        Set olInsp = Nothing
        Set oRng = Nothing
        Set olItms = Nothing
        Set olMail = Nothing
        Set olApp = Nothing
        Set xlSheet = Nothing
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    • Marked as answer by Sajjad05 Friday, February 8, 2019 10:15 AM
    Friday, January 18, 2019 5:31 AM
  • Thanks Graham Mayor for your support but i have an error in this code trying to solve it at line 

    dDate = CDate(oRng.Text)

    I have Type Missmatch error at this line please its really great solution for me if you help me to solve this as well. One more thing i have around 5 emails with different values so i wanted to copy all of them as well in one table.


    • Edited by Sajjad05 Friday, January 18, 2019 10:41 AM
    Friday, January 18, 2019 10:05 AM
  • Change

    Dim dDate As Date

    to

    Dim strDate As String

    Change

    dDate = CDate(oRng.Text)

    to

    strDate = oRng.Text

    Change

     xlSheet.Cells(NextRow, 2) = dDate

    to

     xlSheet.Cells(NextRow, 2) = strDate

    It shouldn't matter how many messages you need to process as long as they share the same format as the example you posted.


    Graham Mayor - Word MVP
    www.gmayor.com

    • Marked as answer by Sajjad05 Friday, February 8, 2019 10:15 AM
    Friday, January 18, 2019 1:45 PM
  • with these changes its copying the whole body of the eamil in the cell 2 instead of only date.
    Friday, January 18, 2019 5:26 PM
  • In that case your message is not as you described. The code is looking for

     With oRng.Find
                    Do While .Execute("system (for ")
                        oRng.collapse 0
                        oRng.moveenduntil ")"
                        Exit Do
                    Loop
                End With

    to extract the date.


    Graham Mayor - Word MVP
    www.gmayor.com

    Saturday, January 19, 2019 4:30 AM
  • @ Graham mayor thanks alot the is issue if fixed now. Its working perfectly fine for personal inbolx but when i changed the folder with a shared folder which is also favorite folder then there is an issue. I changed the line with

    Set olFldr = olNs.GetSharedDefaultFolder(6).Folders("impMail")

    But it doesnt work for me. If you could help me to fix this issue would be grateful

    Monday, January 21, 2019 10:27 AM
  • If you are using a store that is not the default store then you need to establish the store name and set the folder relative to that store. The following should list the store names available

    Sub a()
    Dim olNS As NameSpace
    Dim oStore As Store
        Set olNS = GetNamespace("MAPI")
        For Each oStore In olNS.Stores
    Debug.Print oStore
        Next
        Set oStore = Nothing
        Set olNS = Nothing
    End Sub
    

    Then you can use the appropriate store name in the code to process the required sub folder e.g.

    Sub b()
    Dim olNS As NameSpace
    Dim oStore As Store
    Dim olFldr As Folder
        Set olNS = GetNamespace("MAPI")
        For Each oStore In olNS.Stores
            If oStore = "StoreName" Then
                Set olFldr = oStore.GetRootFolder.folders("Inbox").folders("impMail")
                'do stuff with olFldr'
                Exit For
            End If
        Next
        Set oStore = Nothing
        Set olNS = Nothing
        Set olFldr = Nothing
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    • Marked as answer by Sajjad05 Friday, February 8, 2019 10:15 AM
    Tuesday, January 22, 2019 10:10 AM
  • Thanks for your support.



    • Edited by Sajjad05 Wednesday, January 23, 2019 8:43 AM
    Tuesday, January 22, 2019 4:40 PM
  • may be you could help me in the next step is                            

    I need to insert the data from an excel sheet into a database. and I need this to be done using a MACRO. I have data in excle sheet like this

    Name                            Value              Date

    12345_ABC_DefGeh       12345678        01.11.2018

      ......so on around 15 values.

    and i need to keep a button in the excel sheet and assign a macro to that button so that when i click the button the rows in the excel sheet should be inserted into a database. I already mainained a connection with database. I want to write an sql query to select data from table and put it into database.

    Best Regards,

    sajjad

    • Edited by Sajjad05 Wednesday, January 30, 2019 1:13 PM
    Wednesday, January 30, 2019 1:12 PM
  • You need to specify database.  Dates are handled differently in different databases.  SQLite doesn't even have a date type.
    Friday, February 1, 2019 1:19 PM