将电子邮件自动转换为Excel文件

Question

更新：包含我收到的电子邮件的屏幕截图。

我每天都收到一封电子邮件。在电子邮件的正文中有许多标题，例如：

交易日期：2015年10月28日

数量：20,000,000

货币：美元

有没有办法写一些vba代码，可以找到这封电子邮件并自动扫描正文以查找标识符（交易日期，数量，货币），然后按照后面的内容将其放入工作簿中？基本上找到交易日期将交易日期放入A1（作为标题），以及2015年10月28日的A2。

Answer 1

您需要通过展望事件来完成此操作。打开outlook vba编辑器并将下面的代码粘贴到“ThisOulookSection”模块中。此代码包含一个变量，可帮助我们识别进入收件箱的项目。

请注意，代码包含两个过程。第一个是允许我们初始化“oItemsInbox”变量的钩子。每次打开outlook时都会自动运行此代码，因为它是Application_Startup事件。由于很可能已打开Outlook，只需在程序中单击并按“F5”。

一旦初始化了收件箱项目集合的变量（见上文），进入收件箱的任何新项目将触发第二个过程oItemsInbox_ItemAdd，并允许抓取正在添加的项目以及“项目”。

在发生这一切之后，我只是创建一个工作簿并提取数据。我希望这能让你走上正确的轨道。

Option Explicit

Public WithEvents oItemsInbox As Outlook.Items

' Event to initialize the variable when outlook starts
Private Sub Application_Startup()
    Set oItemsInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
End Sub

'Sample of information to collect
Private Sub oItemsInbox_ItemAdd(ByVal Item As Object)

    Dim oExcelApp As Object
    Dim oWorkbook As Object

    Dim strSubject As String
    Dim strBody As String
    Dim strImportance As String

    With Item
        strSubject = .Subject
        strBody = .Body
        strImportance = .Importance
    End With

    'Create a workbook.
    Set oExcelApp = CreateObject("Excel.Application")
    oExcelApp.Visible = True
    Set oWorkbook = oExcelApp.Workbooks.Add

    ' Add the data
    oWorkbook.Sheets(1).Range("A1:C1").Value = Array("Subject", "Body", "Importance")
    oWorkbook.Sheets(1).Range("A2:C2").Value = Array(strSubject, strBody, strImportance)

End Sub

'Function to get the word next to a keyword
' when the words are all separated by spaces.
Function GetNextWordFromString(ByVal strToSearch As String, ByVal strKeyWord As String) As String

    Const strDELIMITER As String = " "

    Dim arrContents As Variant
    Dim ret As String
    Dim i As Long

    ' Load the contents separating by delimiter
    arrContents = Split(strToSearch, strDELIMITER)

    For i = LBound(arrContents) To UBound(arrContents)

        If arrContents(i) = strKeyWord Then
            If Not i = UBound(arrContents) Then
                ret = Trim$(arrContents(i + 1))
                Exit For
            End If
        End If
    Next i

    'Return the value
    GetNextWordFromString = ret
End Function

希望这会有所帮助：）