如何将电子邮件（Outlook）中的内容提取到 Excel 表格中？

Question

我正在尝试通过 VBA 将 Outlook 中电子邮件中的内容提取到 Excel 表格中。

电子邮件用于假期管理。
在主题中，总是有关键字“Accepted holiday - Mr. James” James 先生是员工的姓名，接受了哪些假期。因此，关键字“Accepted holiday”始终相同，但名称始终更改。
电子邮件包含一个长表，但只有所需的结尾。 如果是搜索一些关键字，也许是最好的。

基准日期 18.12.2014
基准之二 18.12.2014
第一阶段

Excel 文件包含：

• 列表项

• 1 和 2 行是空的。

• 第 3 行包含当年的日期。

• 第 4 行包含 Mo、Tue、Wed、Thur、Fr、Sat、Sun

• 第 5 行为空

• A6、A7、A8、...行包含工人姓名

• 然后在 6、7、8、...行中应该有“X " 代表工人放假的日子。

Const xlUp As Long = -4162

Sub ExportToExcel(MyMail As MailItem)
    Dim strID As String, olNS As Outlook.Namespace
    Dim olMail As Outlook.MailItem
    Dim strFileName As String

    '~~> Excel Variables
    Dim oXLApp As Object, oXLwb As Object, oXLws As Object
    Dim lRow As Long

    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)

    '~~> Establish an EXCEL application object
    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")

    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0

    '~~> Show Excel
    oXLApp.Visible = True

    '~~> Open the relevant file
    Set oXLwb = oXLApp.Workbooks.Open("C:\Sample.xls")

    '~~> Set the relevant output sheet. Change as applicable
    Set oXLws = oXLwb.Sheets("Sheet1")

    lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).Row + 1

    '~~> Write to outlook
    With oXLws
        '
        '~~> Code here to output data from email to Excel File
        '~~> For example
        '
        .Range("A" & lRow).Value = olMail.Subject
        .Range("B" & lRow).Value = olMail.SenderName
        '
    End With

    '~~> Close and Clean up Excel
    oXLwb.Close (True)
    oXLApp.Quit
    Set oXLws = Nothing
    Set oXLwb = Nothing
    Set oXLApp = Nothing

    Set olMail = Nothing
    Set olNS = Nothing
End Sub

Answer 1

您似乎需要从 Outlook 自动化 Excel。 How to automate Microsoft Excel from Visual Basic 文章描述了所有必需的步骤。