Question

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

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

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

我正在使用Outlook 2010和Excel 2010。

enter image description here

Answer 1

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

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

这将帮助您入门。我已对代码进行了评论，以便您不会遇到任何理解它的问题。

首先在outlook模块中粘贴下面提到的代码。

然后

点击工具~~＆gt;规则和提醒
点击“新规则”
点击“从空白规则开始”
选择“收到邮件时检查邮件”
在条件下，点击“主题中包含特定字词”
点击规则说明下的“特定字词”。
在弹出的对话框中键入要检查的单词，然后单击“添加”。
点击“确定”并点击下一步
选择“将其移至指定文件夹”并在同一框中选择“运行脚本”
在下面的框中，指定要运行的特定文件夹以及脚本（模块中的宏）。
点击完成后就完成了。

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

<强> UNTESTED

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

Answer 2

新介绍2

在以前版本的宏“SaveEmailDetails”中，我使用此语句查找收件箱：

Set FolderTgt = CreateObject("Outlook.Application"). _
              GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

我已经安装了更新版本的Outlook，我发现它没有使用默认的收件箱。对于我的每个电子邮件帐户，它都创建了一个单独的商店（以电子邮件地址命名），每个商店都有自己的收件箱。这些收件箱都不是默认设置。

此宏将保存默认收件箱的商店名称输出到立即窗口：

Sub DsplUsernameOfDefaultStore()

  Dim NS As Outlook.NameSpace
  Dim DefaultInboxFldr As MAPIFolder

  Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
  Set DefaultInboxFldr = NS.GetDefaultFolder(olFolderInbox)

  Debug.Print DefaultInboxFldr.Parent.Name

End Sub

在我的安装中，输出：“Outlook Data File”。

我在宏“SaveEmailDetails”中添加了一个额外的语句，显示了如何访问任何商店的收件箱。

新介绍1

许多人已经拿到了下面的宏，发现它很有用并且直接与我联系以获得进一步的建议。在这些联系之后，我对宏做了一些改进，所以我在下面发布了修订版。我还添加了一对宏，它们将为具有Outlook层次结构的任何文件夹返回MAPIFolder对象。如果您希望访问默认文件夹以外的其他文件，这些内容非常有用。

原始文本引用了一个与日期问题相关的日期问题。第一个问题已被删除，因此链接已丢失。该链接指向Update excel sheet based on outlook mail (closed)

原始文字

该问题的变化数量惊人：“如何从Outlook电子邮件中提取数据到Excel工作簿？”例如，8月13日在[outlook-vba]上提出了两个问题。这个问题引用了我试图回答的12月份的变化。

对于12月的问题，我得到了一个两部分的答案。第一部分是一系列教学宏，它们探索了Outlook文件夹结构并将数据写入文本文件或Excel工作簿。第二部分讨论了如何设计提取过程。对于这个问题，Siddarth提供了一个优秀，简洁的答案，然后是后续阶段的帮助。

每个变体的提问者似乎无法理解的是，向我们展示数据在屏幕上的样子并不能告诉我们文本或html正文的样子。这个答案试图解决这个问题。

下面的宏比Siddarth更复杂，但比我12月回答的那些更简单。还有更多可以添加，但我认为这足以开始。

宏创建一个新的Excel工作簿并输出收件箱中每个电子邮件的选定属性以创建此工作表：

Example of worksheet created by macro

在宏的顶部附近有一个包含八个哈希（＃）的注释。下面的语句必须才能更改，因为它标识了将在其中创建Excel工作簿的文件夹。

包含哈希值的所有其他注释都建议修改以使宏适应您的要求。

如何识别从中提取数据的电子邮件？它是发送者，主体，身体内的字符串还是所有这些？这些评论为消除不感兴趣的电子邮件提供了一些帮助。如果我正确理解了这个问题，那么有趣的电子邮件会有Subject = "Task Completed"。

这些评论没有帮助从有趣的电子邮件中提取数据，但工作表显示了电子邮件正文的文本和html版本（如果它们存在）。我的想法是你可以看到宏会看到什么并开始设计提取过程。

这未在上面的屏幕图像中显示，但宏在文本正文上输出两个版本。第一个版本未更改，这意味着符合制表符，回车符，换行符，并且任何非中断空格看起来像空格。在第二个版本中，我用字符串[TB]，[CR]，[LF]和[NBSP]替换了这些代码，因此它们是可见的。如果我的理解是正确的，我希望在第二个文本正文中看到以下内容：

活性[TAB]计数[CR] [LF]打开[TAB] 35 [CR] [LF] HCQA [TAB] 42 [CR] [LF] HCQC [TAB] 60 [CR] [LF] HAbst [TAB ] 50 45 5 2 2 1 [CR] [LF]等等

从这个字符串的原始值中提取值应该不难。

除了电子邮件的属性之外，我还会尝试修改我的宏来输出提取的值。只有当我成功实现此更改时，才会尝试将提取的数据写入现有工作簿。我还会将已处理的电子邮件移动到其他文件夹。我已经说明了必须进行这些更改的地方，但没有给出进一步的帮助。如果你到达需要这些信息的地步，我会回答一个补充问题。

祝你好运。

原始文本中包含的最新版本的宏

Option Explicit
Public Sub SaveEmailDetails()

  ' This macro creates a new Excel workbook and writes to it details
  ' of every email in the Inbox.

  ' Lines starting with hashes either MUST be changed before running the
  ' macro or suggest changes you might consider appropriate.

  Dim AttachCount As Long
  Dim AttachDtl() As String
  Dim ExcelWkBk As Excel.Workbook
  Dim FileName As String
  Dim FolderTgt As MAPIFolder
  Dim HtmlBody As String
  Dim InterestingItem As Boolean
  Dim InxAttach As Long
  Dim InxItemCrnt As Long
  Dim PathName As String
  Dim ReceivedTime As Date
  Dim RowCrnt As Long
  Dim SenderEmailAddress As String
  Dim SenderName As String
  Dim Subject As String
  Dim TextBody As String
  Dim xlApp As Excel.Application

  ' The Excel workbook will be created in this folder.
  ' ######## Replace "C:\DataArea\SO" with the name of a folder on your disc.
  PathName = "C:\DataArea\SO"

  ' This creates a unique filename.
  ' #### If you use a version of Excel 2003, change the extension to "xls".
  FileName = Format(Now(), "yymmdd hhmmss") & ".xlsx"

  ' Open own copy of Excel
  Set xlApp = Application.CreateObject("Excel.Application")
  With xlApp
    ' .Visible = True         ' This slows your macro but helps during debugging
    .ScreenUpdating = False ' Reduces flash and increases speed
    ' Create a new workbook
    ' #### If updating an existing workbook, replace with an
    ' #### Open workbook statement.
    Set ExcelWkBk = xlApp.Workbooks.Add
    With ExcelWkBk
      ' #### None of this code will be useful if you are adding
      ' #### to an existing workbook.  However, it demonstrates a
      ' #### variety of useful statements.
      .Worksheets("Sheet1").Name = "Inbox"    ' Rename first worksheet
      With .Worksheets("Inbox")
        ' Create header line
        With .Cells(1, "A")
          .Value = "Field"
          .Font.Bold = True
        End With
        With .Cells(1, "B")
          .Value = "Value"
          .Font.Bold = True
        End With
        .Columns("A").ColumnWidth = 18
        .Columns("B").ColumnWidth = 150
      End With
    End With
    RowCrnt = 2
  End With

  ' FolderTgt is the folder I am going to search.  This statement says
  ' I want to seach the Inbox.  The value "olFolderInbox" can be replaced
  ' to allow any of the standard folders to be searched.
  ' See FindSelectedFolder() for a routine that will search for any folder.
  Set FolderTgt = CreateObject("Outlook.Application"). _
              GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
  ' #### Use the following the access a non-default Inbox.
  ' #### Change "Xxxx" to name of one of your store you want to access.
  Set FolderTgt = Session.Folders("Xxxx").Folders("Inbox")

  ' This examines the emails in reverse order. I will explain why later.
  For InxItemCrnt = FolderTgt.Items.Count To 1 Step -1
    With FolderTgt.Items.Item(InxItemCrnt)
      ' A folder can contain several types of item: mail items, meeting items,
      ' contacts, etc.  I am only interested in mail items.
      If .Class = olMail Then
        ' Save selected properties to variables
        ReceivedTime = .ReceivedTime
        Subject = .Subject
        SenderName = .SenderName
        SenderEmailAddress = .SenderEmailAddress
        TextBody = .Body
        HtmlBody = .HtmlBody
        AttachCount = .Attachments.Count
        If AttachCount > 0 Then
          ReDim AttachDtl(1 To 7, 1 To AttachCount)
          For InxAttach = 1 To AttachCount
            ' There are four types of attachment:
            '  *   olByValue       1
            '  *   olByReference   4
            '  *   olEmbeddedItem  5
            '  *   olOLE           6
            Select Case .Attachments(InxAttach).Type
              Case olByValue
            AttachDtl(1, InxAttach) = "Val"
              Case olEmbeddeditem
            AttachDtl(1, InxAttach) = "Ebd"
              Case olByReference
            AttachDtl(1, InxAttach) = "Ref"
              Case olOLE
            AttachDtl(1, InxAttach) = "OLE"
              Case Else
            AttachDtl(1, InxAttach) = "Unk"
            End Select
            ' Not all types have all properties.  This code handles
            ' those missing properties of which I am aware.  However,
            ' I have never found an attachment of type Reference or OLE.
            ' Additional code may be required for them.
            Select Case .Attachments(InxAttach).Type
              Case olEmbeddeditem
                AttachDtl(2, InxAttach) = ""
              Case Else
                AttachDtl(2, InxAttach) = .Attachments(InxAttach).PathName
            End Select
            AttachDtl(3, InxAttach) = .Attachments(InxAttach).FileName
            AttachDtl(4, InxAttach) = .Attachments(InxAttach).DisplayName
            AttachDtl(5, InxAttach) = "--"
            ' I suspect Attachment had a parent property in early versions
            ' of Outlook. It is missing from Outlook 2016.
            On Error Resume Next
            AttachDtl(5, InxAttach) = .Attachments(InxAttach).Parent
            On Error GoTo 0
            AttachDtl(6, InxAttach) = .Attachments(InxAttach).Position
            ' Class 5 is attachment.  I have never seen an attachment with
            ' a different class and do not see the purpose of this property.
            ' The code will stop here if a different class is found.
            Debug.Assert .Attachments(InxAttach).Class = 5
            AttachDtl(7, InxAttach) = .Attachments(InxAttach).Class
          Next
        End If
        InterestingItem = True
      Else
        InterestingItem = False
      End If
    End With
    ' The most used properties of the email have been loaded to variables but
    ' there are many more properies.  Press F2.  Scroll down classes until
    ' you find MailItem.  Look through the members and note the name of
    ' any properties that look useful.  Look them up using VB Help.

    ' #### You need to add code here to eliminate uninteresting items.
    ' #### For example:
    'If SenderEmailAddress <> "JohnDoe@AcmeSoftware.co.zy" Then
    '  InterestingItem = False
    'End If
    'If InStr(Subject, "Accounts payable") = 0 Then
    '  InterestingItem = False
    'End If
    'If AttachCount = 0 Then
    '  InterestingItem = False
    'End If

    ' #### If the item is still thought to be interesting I
    ' #### suggest extracting the required data to variables here.

    ' #### You should consider moving processed emails to another
    ' #### folder.  The emails are being processed in reverse order
    ' #### to allow this removal of an email from the Inbox without
    ' #### effecting the index numbers of unprocessed emails.

    If InterestingItem Then
      With ExcelWkBk
        With .Worksheets("Inbox")
          ' #### This code creates a dividing row and then
          ' #### outputs a property per row.  Again it demonstrates
          ' #### statements that are likely to be useful in the final
          ' #### version
          ' Create dividing row between emails
          .Rows(RowCrnt).RowHeight = 5
          .Range(.Cells(RowCrnt, "A"), .Cells(RowCrnt, "B")) _
                                      .Interior.Color = RGB(0, 255, 0)
          RowCrnt = RowCrnt + 1
          .Cells(RowCrnt, "A").Value = "Sender name"
          .Cells(RowCrnt, "B").Value = SenderName
          RowCrnt = RowCrnt + 1
          .Cells(RowCrnt, "A").Value = "Sender email address"
          .Cells(RowCrnt, "B").Value = SenderEmailAddress
          RowCrnt = RowCrnt + 1
          .Cells(RowCrnt, "A").Value = "Received time"
          With .Cells(RowCrnt, "B")
            .NumberFormat = "@"
            .Value = Format(ReceivedTime, "mmmm d, yyyy h:mm")
          End With
          RowCrnt = RowCrnt + 1
          .Cells(RowCrnt, "A").Value = "Subject"
          .Cells(RowCrnt, "B").Value = Subject
          RowCrnt = RowCrnt + 1
          If AttachCount > 0 Then
            .Cells(RowCrnt, "A").Value = "Attachments"
            .Cells(RowCrnt, "B").Value = "Inx|Type|Path name|File name|Display name|Parent|Position|Class"
            RowCrnt = RowCrnt + 1
            For InxAttach = 1 To AttachCount
              .Cells(RowCrnt, "B").Value = InxAttach & "|" & _
                                           AttachDtl(1, InxAttach) & "|" & _
                                           AttachDtl(2, InxAttach) & "|" & _
                                           AttachDtl(3, InxAttach) & "|" & _
                                           AttachDtl(4, InxAttach) & "|" & _
                                           AttachDtl(5, InxAttach) & "|" & _
                                           AttachDtl(6, InxAttach) & "|" & _
                                           AttachDtl(7, InxAttach)
              RowCrnt = RowCrnt + 1
            Next
          End If
          If TextBody <> "" Then

            ' ##### This code was in the original version of the macro
            ' ##### but I did not find it as useful as the other version of
            ' ##### the text body.  See below
            ' This outputs the text body with CR, LF and TB obeyed
            'With .Cells(RowCrnt, "A")
            '  .Value = "text body"
            '  .VerticalAlignment = xlTop
            'End With
            'With .Cells(RowCrnt, "B")
            '  ' The maximum size of a cell 32,767
            '  .Value = Mid(TextBody, 1, 32700)
            '  .WrapText = True
            'End With
            'RowCrnt = RowCrnt + 1

            ' This outputs the text body with NBSP, CR, LF and TB
            ' replaced by strings.
            With .Cells(RowCrnt, "A")
              .Value = "text body"
              .VerticalAlignment = xlTop
            End With
            TextBody = Replace(TextBody, Chr(160), "[NBSP]")
            TextBody = Replace(TextBody, vbCr, "[CR]")
            TextBody = Replace(TextBody, vbLf, "[LF]")
            TextBody = Replace(TextBody, vbTab, "[TB]")
            With .Cells(RowCrnt, "B")
              ' The maximum size of a cell 32,767
              .Value = Mid(TextBody, 1, 32700)
              .WrapText = True
            End With
            RowCrnt = RowCrnt + 1
          End If

          If HtmlBody <> "" Then

            ' ##### This code was in the original version of the macro
            ' ##### but I did not find it as useful as the other version of
            ' ##### the html body.  See below
            ' This outputs the html body with CR, LF and TB obeyed
            'With .Cells(RowCrnt, "A")
            '  .Value = "Html body"
            '  .VerticalAlignment = xlTop
            'End With
            'With .Cells(RowCrnt, "B")
            '  .Value = Mid(HtmlBody, 1, 32700)
            '  .WrapText = True
            'End With
            'RowCrnt = RowCrnt + 1

            ' This outputs the html body with NBSP, CR, LF and TB
            ' replaced by strings.
            With .Cells(RowCrnt, "A")
              .Value = "Html body"
              .VerticalAlignment = xlTop
            End With
            HtmlBody = Replace(HtmlBody, Chr(160), "[NBSP]")
            HtmlBody = Replace(HtmlBody, vbCr, "[CR]")
            HtmlBody = Replace(HtmlBody, vbLf, "[LF]")
            HtmlBody = Replace(HtmlBody, vbTab, "[TB]")
            With .Cells(RowCrnt, "B")
              .Value = Mid(HtmlBody, 1, 32700)
              .WrapText = True
            End With
            RowCrnt = RowCrnt + 1

          End If
        End With
      End With
    End If
  Next

  With xlApp
    With ExcelWkBk
      ' Write new workbook to disc
      If Right(PathName, 1) <> "\" Then
        PathName = PathName & "\"
      End If
      .SaveAs FileName:=PathName & FileName
      .Close
    End With
    .Quit   ' Close our copy of Excel
  End With

  Set xlApp = Nothing       ' Clear reference to Excel

End Sub

原始帖子中未包含宏，但上述宏的某些用户认为这些宏有用。

Public Sub FindSelectedFolder(ByRef FolderTgt As MAPIFolder, _
                              ByVal NameTgt As String, ByVal NameSep As String)

  ' This routine (and its sub-routine) locate a folder within the hierarchy and
  ' returns it as an object of type MAPIFolder

  ' NameTgt   The name of the required folder in the format:
  '              FolderName1 NameSep FolderName2 [ NameSep FolderName3 ] ...
  '           If NameSep is "|", an example value is "Personal Folders|Inbox"
  '           FolderName1 must be an outer folder name such as
  '           "Personal Folders". The outer folder names are typically the names
  '           of PST files.  FolderName2 must be the name of a folder within
  '           Folder1; in the example "Inbox".  FolderName2 is compulsory.  This
  '           routine cannot return a PST file; only a folder within a PST file.
  '           FolderName3, FolderName4 and so on are optional and allow a folder
  '           at any depth with the hierarchy to be specified.
  ' NameSep   A character or string used to separate the folder names within
  '           NameTgt.
  ' FolderTgt On exit, the required folder.  Set to Nothing if not found.

  ' This routine initialises the search and finds the top level folder.
  ' FindSelectedSubFolder() is used to find the target folder within the
  ' top level folder.

  Dim InxFolderCrnt As Long
  Dim NameChild As String
  Dim NameCrnt As String
  Dim Pos As Long
  Dim TopLvlFolderList As Folders

  Set FolderTgt = Nothing   ' Target folder not found

  Set TopLvlFolderList = _
          CreateObject("Outlook.Application").GetNamespace("MAPI").Folders

  ' Split NameTgt into the name of folder at current level
  ' and the name of its children
  Pos = InStr(NameTgt, NameSep)
  If Pos = 0 Then
    ' I need at least a level 2 name
    Exit Sub
  End If
  NameCrnt = Mid(NameTgt, 1, Pos - 1)
  NameChild = Mid(NameTgt, Pos + 1)

  ' Look for current name.  Drop through and return nothing if name not found.
  For InxFolderCrnt = 1 To TopLvlFolderList.Count
    If NameCrnt = TopLvlFolderList(InxFolderCrnt).Name Then
      ' Have found current name. Call FindSelectedSubFolder() to
      ' look for its children
      Call FindSelectedSubFolder(TopLvlFolderList.Item(InxFolderCrnt), _
                                            FolderTgt, NameChild, NameSep)
      Exit For
    End If
  Next

End Sub
Public Sub FindSelectedSubFolder(FolderCrnt As MAPIFolder, _
                      ByRef FolderTgt As MAPIFolder, _
                      ByVal NameTgt As String, ByVal NameSep As String)

  ' See FindSelectedFolder() for an introduction to the purpose of this routine.
  ' This routine finds all folders below the top level

  ' FolderCrnt The folder to be seached for the target folder.
  ' NameTgt    The NameTgt passed to FindSelectedFolder will be of the form:
  '               A|B|C|D|E
  '            A is the name of outer folder which represents a PST file.
  '            FindSelectedFolder() removes "A|" from NameTgt and calls this
  '            routine with FolderCrnt set to folder A to search for B.
  '            When this routine finds B, it calls itself with FolderCrnt set to
  '            folder B to search for C.  Calls are nested to whatever depth are
  '            necessary.
  ' NameSep    As for FindSelectedSubFolder
  ' FolderTgt  As for FindSelectedSubFolder

  Dim InxFolderCrnt As Long
  Dim NameChild As String
  Dim NameCrnt As String
  Dim Pos As Long

  ' Split NameTgt into the name of folder at current level
  ' and the name of its children
  Pos = InStr(NameTgt, NameSep)
  If Pos = 0 Then
    NameCrnt = NameTgt
    NameChild = ""
  Else
    NameCrnt = Mid(NameTgt, 1, Pos - 1)
    NameChild = Mid(NameTgt, Pos + 1)
  End If

  ' Look for current name.  Drop through and return nothing if name not found.
  For InxFolderCrnt = 1 To FolderCrnt.Folders.Count
    If NameCrnt = FolderCrnt.Folders(InxFolderCrnt).Name Then
      ' Have found current name.
      If NameChild = "" Then
        ' Have found target folder
        Set FolderTgt = FolderCrnt.Folders(InxFolderCrnt)
      Else
        'Recurse to look for children
        Call FindSelectedSubFolder(FolderCrnt.Folders(InxFolderCrnt), _
                                            FolderTgt, NameChild, NameSep)
      End If
      Exit For
    End If
  Next

  ' If NameCrnt not found, FolderTgt will be returned unchanged.  Since it is
  ' initialised to Nothing at the beginning, that will be the returned value.

End Sub

如何使用VBA或宏将Outlook邮件复制到Excel

2 个答案: