从电子邮件主体中提取特定数据 [英] Extract specific data from emailbody

问题描述

我们如何将特定数据从outlook body消息导出到excel。

on 2 model of mail

以及我们如何计算邮件正文上的行数。

a给你我的例子。

邮件类型1一个是

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

邮件类型2一个是

mail type2 one is

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

我收到邮件类型和2个相同的收件箱邮件

我在Excel中需要的是这样的

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

我的尝试：



i尝试了这个，如果有人可以帮助我

What I have tried:

i tried this if some one can help me

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

推荐答案

试试这个：

Try this:

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.

这篇关于从电子邮件主体中提取特定数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！