Extract specific data from emailbody

Question

0.00/5 (No votes)

See more:

how we can export a specific data from outlook body message to excel .
on 2 model of mail
and how we can count number of lines on mail body.
a give you my example .
mail type1 one is

[First Name],Boby Rayan
[Cont Number], A0ED011011782
[Send Date],03/03/18
[Total Mt],00742241
[Total Mtc],00209166
[Total Mtb],00533075
[Total Mtfs],00101361

mail type2 one is

[First Name],David porter
[Cont Number], A1UF011011598
[Send Date],03/01/18
[Total Mtb],00258552
[Total Mtfs],00146186

and i receive mail type and 2 in same inbox mail
what i need in excel is like this

First Name * Cont Number   * Send Date* Total Mt * Total Mtc * Total Mtb * Total Mtfs
Boby Rayan * A0ED011011782 * 03/03/18 * 00742241 * 00209166  *00533075   * 00101361
David porter*A1UF011011598 * 03/01/18  *         *           * 00258552  * 00101361

What I have tried:

i tried this if some one can help me

VB

Sub Extract()
 On Error Resume Next
 Set myOlApp = Outlook.Application
 Set mynamespace = myOlApp.GetNamespace("mapi")
 Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
 
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim x As Long
Dim arrHeaders As Variant



Set xlobj = CreateObject("excel.application.15")
 xlobj.Visible = True
 xlobj.Workbooks.Add
 xlobj.Worksheets("Sheet1").Name = "Statusmail"
 
'Set the header
 xlobj.Range("a" & 1).Value = "Sender"
 xlobj.Range("a" & 1).Font.Bold = "True"
 'xlobj.Range("b" & 1).Value = "Date"
 'xlobj.Range("b" & 1).Font.Bold = "True"
 xlobj.Range("c" & 1).Value = "First Name"
 xlobj.Range("c" & 1).Font.Bold = True
 xlobj.Range("d" & 1).Value = "Cont Number"
 xlobj.Range("d" & 1).Font.Bold = True
 xlobj.Range("e" & 1).Value = "Send Date"
 xlobj.Range("e" & 1).Font.Bold = True
 xlobj.Range("f" & 1).Value = "Total Mt"
 xlobj.Range("f" & 1).Font.Bold = True
 xlobj.Range("g" & 1).Value = "Total Mtc"
 xlobj.Range("g" & 1).Font.Bold = True
 xlobj.Range("h" & 1).Value = "Total Mtb"
 xlobj.Range("h" & 1).Font.Bold = True
 xlobj.Range("i" & 1).Value = "Total Mtfs"
 xlobj.Range("i" & 1).Font.Bold = True
For x = 1 To myfolder.Items.Count
  Set myitem = myfolder.Items(x)
  msgtext = myitem.Body
  'search for specific text
    delimtedMessage = Replace(msgtext, "[First Name],", "###")
    delimtedMessage = Replace(delimtedMessage, "[Cont Number],", "###")
    delimtedMessage = Replace(delimtedMessage, "[Send Date],", "###")
    delimtedMessage = Replace(delimtedMessage, "[Total Mt],", "###")
    delimtedMessage = Replace(delimtedMessage, "[Total Mtc],", "###")
    delimtedMessage = Replace(delimtedMessage, "[Total Mtb],", "###")
    delimtedMessage = Replace(delimtedMessage, "[Total Mtfs],", "###")
    messageArray = Split(delimtedMessage, "###")
   'write to excel
    xlobj.Range("a" & x + 1).Value = myitem.To
    xlobj.Range("b" & x + 1).Value = messageArray(0)
    xlobj.Range("c" & x + 1).Value = messageArray(1)
    xlobj.Range("d" & x + 1).Value = messageArray(2)
    xlobj.Range("e" & x + 1).Value = messageArray(3)
    xlobj.Range("f" & x + 1).Value = messageArray(4)
    xlobj.Range("g" & x + 1).Value = messageArray(5)
    xlobj.Range("h" & x + 1).Value = messageArray(6)
    xlobj.Range("i" & x + 1).Value = messageArray(7) 


 Next
 End
 End Sub

Posted 12-Mar-18 6:13am

bbrahim

Updated 12-Mar-18 8:37am

Maciej Los

v3

Add a Solution

Comments

Maciej Los 12-Mar-18 13:25pm

And what's wrong with your code?

1 solution

Add a Solution

Add your solution here

Treat my content as plain text, not as HTML

Preview 0

…

Existing Members

Sign in to your account

...or Join us

Download, Vote, Comment, Publish.

Your Email
Password
Forgot your password?

Your Email
This email is in use. Do you need your password?
Optional Password

I have read and agree to the Terms of Service and Privacy Policy
Please subscribe me to the CodeProject newsletters

When answering a question please:

Read the question carefully.
Understand that English isn't everyone's first language so be lenient of bad spelling and grammar.
If a question is poorly phrased then either ask for clarification, ignore it, or edit the question and fix the problem. Insults are not welcome.
Don't tell someone to read the manual. Chances are they have and don't get it. Provide an answer or move on to the next question.

Let's work to help developers, not make them feel stupid.

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

Maciej Los · Answer 1 · 2018-03-12T08:37:00

Try this:

VB

Dim xlObj As Object, xlWbk As Object, xlWsh As Object
Dim piecesToFind As Variant
Dim i As Integer, j As Integer, k As Integer, r As Integer, x As Integer

piecesToFind = Array("[First Name]", "[Cont Number]", "[Send Date]", "[Total Mt]", "[Total Mtc]", "[Total Mtb]", "[Total Mtfs]")

'further
Set xlObj = CreateObject("Excel.Application") 'Excel application
Set xlWbk = xlobj.Workbooks.Add 'workbook
Set xlWsh = xlobj.Worksheets(1) 'worksheet

xlWsh.Name = "Statusmail"

'Set the header
With xlWsh
    .Range("A" & 1).Value = "Sender"
    .Range("A" & 1).Font.Bold = "True"
    '...

End With

r = 2
For x = 1 To myfolder.Items.Count
    Set myitem = myfolder.Items(x)
    msgtext = myitem.Body
    For i = LBound(piecesToFind) To UBound(piecesToFind)
        j = InStr(1, msgText, piecesToFind(i), vbBinaryCompare)
        k = InStr(j + 1, msgText, vbCrLf, vbBinaryCompare) ' replace vbCrLf with the correct one
        If k = 0 Then k = Len(msgText)
        If j > 0 And k > 0 Then
            xlWsh.Range("A" & r).Offset(ColumnOffset:=i) = "'" & Mid(msgText, j + Len(piecesToFind(i)) + 1, k - j - Len(piecesToFind(i)))
       End If
    Next
    r = r +1    
Next

Note: some pieces of code have been omitted.