如何复制电子邮件正文中的特定文本? [英] How to copy specific text from the body of the email?
问题描述
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
嗨
@ ABC4:请在系统中添加以下详细信息( 2019年1月12日):
@ABC4: please add the following detail in system (for 12-Jan-2019):
12345_ABC_MakOpt --- 264532154.78
12345_ABC_GAPFee --- 145626547.80
谢谢
´-----------------------------------------------------'设置'-----------------------------------------------------
´ ----------------------------------------------------- '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´
推荐答案
您的问题对于特定的答案太含糊.我所能提供的只是第一阶段的一些指导.
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.
"@ ABC4"是否固定?是"@ ABC4:请在系统中添加以下详细信息(用于)是否已固定?
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?
在下面的代码中，替换 vbCR&vbLf (如果需要)，然后运行它:
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
现在，您可以看到文本正文为线条.注意:第一行是数字0.顶部永远不会有空行吗?顶部总是有空白行吗?会有所不同吗?我将假设顶部始终有一个空白行.如果该假设不正确，则下面的代码将需要修改.
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.
如果第1行是"xxxxxxxxxx日期):"，则可以提取日期，这样:
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))
或
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
输出为:
Date=12/01/2019 Name=12345_ABC_MakOpt Amount=264532154.78
Date=12/01/2019 Name=12345_ABC_GAPFee Amount=145626547.8
新部分显示了如何将电子邮件中的数据添加到工作表中
这是本节的第二个版本，因为OP改变了对所需格式的想法.
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.
我用以下标题创建了一个新的工作簿和一个名为"Fixings"的新工作表:
I created a new workbook and a new worksheet named "Fixings" with the following headings:
处理完我的虚假电子邮件后，工作表如下:
After processing my fake emails, the worksheet looked like:
行的顺序取决于找到电子邮件的顺序.您可能首先想要最新的.对工作表进行排序不在此答案的范围内.注意:列标题告诉宏要记录哪些值.如果在电子邮件中添加了新行，请添加新的列标题，并且将保存该值，而无需更改宏.
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.
除了一个例外，我将不解释我使用的VBA语句，因为可以很容易地在网上搜索"VBA xxxxx"并查找语句xxxxx的规范.唯一的例外是使用两个集合来保存未决数据.其余的说明描述了我采用此方法的原因.
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
我本可以写出 Cells(Row，1).Value = Date .这有两个缺点:(1)如果date列曾经被移动过，则必须在代码中搜索访问它的语句；(2)您必须记住第1或2或3列中的内容，这使您的代码更难于理解.读.我避免将文字用于行号或列号.键入ColFixDataFirst(而不是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.
我注意到在添加到您的问题中的代码中，您使用命名范围来达到相同的效果.VBA的问题在于，通常有几种方法可以达到相同的效果.我更喜欢常量，但是我们每个人都必须选择自己喜欢的常量.
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.
在一个部门工作过，该部门处理了许多来自外部的电子邮件和工作簿，其中包含有用的数据，我可以告诉您它们的格式一直在变化.将有一个额外的空白行，或者将删除现有的空白行.将会有额外的数据，或者现有数据将以不同的顺序进行.作者做出了他们认为会有所帮助的更改，但很少做任何有用的事情，例如询问接收者是否愿意更改，甚至警告他们更改.我见过的最糟糕的情况是两个数字列被颠倒了，而且几个月都没有注意到.幸运的是，我没有参与其中，因为这是一场噩梦，要从我们的系统中删除有问题的数据，然后再导入正确的数据.我会检查所有我能想到的内容，并拒绝处理与我期望的不完全相同的电子邮件.错误消息都被写入立即窗口，这在开发过程中很方便.您可能要使用MsgBox或将其写入文件.如果电子邮件处理成功，则不会将其删除；将其移至子文件夹，以便在再次需要时可以对其进行检索.
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 是一个Outlook常量.请勿将 olMail 或任何其他保留字用作变量名.
olMail is an Outlook constant. Do not use olMail or any other reserved word as a variable name.
我使用了 Session 而不是NameSpace.它们应该是等效的，但是我曾经遇到无法诊断的命名空间问题，因此不再使用它们.
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.
我不对电子邮件进行排序，因为您的代码没有利用对电子邮件进行排序的优势.也许您可以利用ReceivedTime排序的优势，但是我看到了潜在的问题，这些问题很难避免.
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.
我按相反的顺序处理电子邮件，因为它们是按位置访问的.例如，如果将电子邮件5移动到另一个文件夹，则以前的电子邮件6现在是电子邮件5，并且 For 循环将其跳过.如果以相反的顺序处理电子邮件，则您不介意电子邮件6现在是电子邮件5，因为您已经处理过该电子邮件.
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.
如果您未设置保存日期或金额的单元格的 NumberFormat ，则会根据Microsoft在您所在国家/地区的默认设置显示它们.我使用了我最喜欢的显示格式.更改为您的收藏夹.
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.
在处理完整个电子邮件并提取所需的数据之前，代码不会向工作表输出任何内容.这意味着必须存储早期数据行中的数据，直到处理完所有行.我使用了两个 Collections : PendingNames 和 PendingAmts .这不是将数据存储在我为自己编写的宏中的方式.我的问题是替代方法更复杂，或者需要更高级的VBA.
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
这篇关于如何复制电子邮件正文中的特定文本?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
