excel - 如何使用 VBA 或宏将 Outlook 邮件消息复制到 Excel 中

Question

我是 VBA 和宏的新手。如果有人帮助我使用 VBA 代码和宏，那将会很有帮助。

每天我都会收到大约 50-60 封邮件，其中包含一个标准主题:“任务已完成”。我为所有这些邮件创建了一条规则，将其移至特定文件夹:“任务已完成”。

每天阅读所有 50-60 封邮件并更新所有邮件非常耗时。进入我的收件箱的所有 50-60 封邮件都将具有相同的主题，但来自不同的用户。邮件正文会有所不同。

我使用的是 Outlook 2010 和 Excel 2010。

Answer 1

由于您没有提到需要复制的内容，因此我在下面的代码中将该部分留空。

此外，您不需要先将电子邮件移至该文件夹，然后在该文件夹中运行宏。您可以对传入邮件运行宏，然后同时将其移至文件夹。

这将帮助您开始。我已经对代码进行了注释，这样您就不会在理解它时遇到任何问题。

首先将下面提到的代码粘贴到 Outlook 模块中。

然后

1. 点击“工具”~~>“规则和警报”
2. 点击“新规则”
3. 点击“从空白规则开始”
4. 选择“消息到达时检查”
5. 在有条件的情况下，点击“主题中包含特定字词”
6. 点击规则说明下的“特定单词”。
7. 在弹出的对话框中输入您要检查的单词，然后点击“添加”。
8. 点击“确定”，然后点击下一步
9. 选择“将其移至指定文件夹”并在同一框中选择“运行脚本”
10. 在下面的框中，指定要运行的特定文件夹以及脚本(模块中的宏)。
11. 点击“完成”即可完成。

当新电子邮件到达时，该电子邮件不仅会移动到您指定的文件夹，而且其中的数据也会导出到 Excel。

代码

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

跟进

要从电子邮件正文中提取内容，您可以使用 SPLIT() 对其进行拆分，然后从中解析出相关信息。请参阅此示例

Dim MyAr() As String

MyAr = Split(olMail.body, vbCrLf)

For i = LBound(MyAr) To UBound(MyAr)
    '~~> This will give you the contents of your email
    '~~> on separate lines
    Debug.Print MyAr(i)
Next i