基于outlook mail更新excel工作表

我的目标是在收到带有特定主题的邮件时更新excel工作表（我设置了将相关邮件移动到文件夹的规则）

我在这个网站上看到了类似的帖子，但给出的代码并不完整。作为一名“专业”或“技术人员”，编写代码非常困难

邮件内容包括：

文件名： 业主名称： 上次更新日期： 文件位置（这将是共享驱动器路径）：

我每天都会收到这封邮件，需要在excel表格中更新这些信息。（我将一直营业到月底）

---

请帮帮我。提前感谢

介绍

在这个答案的第一个版本中，我提到了另一个问题，我现在知道你将无法阅读

您需要的所有代码都在这里，但这并不是作为即时解决方案编写的。这是一个教程，向您介绍Outlook对象模型，从Outlook数据库中获取数据并将其导入Excel工作簿。不要担心你不是“专业人士”或“技术人员”；我们曾经都是新手。完成各部分。如果你不完全理解，不要担心。现在就把你需要的东西挑出来。如果您想增强您的解决方案，请返回本教程以及您将复制到光盘中的代码

在以下部分中，AnswerA（）和AnswerB（）旨在帮助您了解文件夹结构。AnswerC1（）也是一种短期培训辅助工具。然而，AnswerC2（）和AnswerC3（）是您可能永远需要的子程序。如果你保留了它们，我建议你重新命名它们；例如：FindFolder（）和FindFolderSub（）

AnswerD（）也是一种培训辅助工具，但您应该保留它。这将向您展示如何访问一些邮件项目属性，但您可能需要访问比我显示的更多的邮件项目属性。在VB编辑器中，单击F2以显示对象资源管理器。向下滚动到MailItem的类列表。您将看到一个包含100多个方法和属性的列表。有些是显而易见的，但您必须使用VB帮助来发现许多的目的。展开AnswerD（）以使用您认为可能有用的方法或显示属性

Answare（）是一种开发辅助工具，但也为宏提供了结构。目前，它将文件夹中邮件的文本和html正文输出到光盘。您现在不想这样做，但您可能会这样做。我将所有电子邮件归档到Excel。我为每封电子邮件创建一行，其中列有发件人、收件人、主题、日期等。我将文本正文、html正文和任何附件保存到光盘，并创建指向它们的超链接。我有几年前从多个Outlook安装中收到的电子邮件

AnswerF1（）说明如何创建新的Excel工作簿，AnswerF2（）说明如何打开现有的Excel工作簿。我想AnswerF2（）就是你需要的

这里有很多内容，但是如果您稳定地完成它，您将了解Outlook对象模型以及如何实现您的目标

健康警告

这个答案中的一切都是通过实验发现的。我从VB帮助开始，使用F2访问对象模型并进行实验，直到找到有效的方法。我确实买了一本极力推荐的参考书，但里面没有我没有发现的重要内容，而且遗漏了我发现的很多内容

我怀疑我所获得的知识的一个关键特征是它基于许多不同的安装。遇到的一些问题可能是安装错误造成的，这可以解释为什么参考书作者不知道这些问题

下面的代码已经用Excel2003和OutlookExchange2003和2007进行了测试

如果您不熟悉Outlook VBA，请开始使用

打开“Outlook”或“Outlook Exchange”。这些宏不适用于“Outlook Express”

从工具栏中，选择工具、宏、安全性。如果安全级别尚未达到“中等”，请将其更改为“中等”。这意味着只能在您明确批准的情况下运行宏

要启动Outlook VB编辑器，请执行以下操作之一：

1） 从工具栏中，选择工具、宏、宏 或者单击Alt+F11 2） 选择启用宏

从工具栏中，选择“插入，模块”

你可以看到一个、两个或三个窗口。左边应该是项目浏览器。您现在不需要它，但如果缺少它，请单击Ctrl+R以显示它。右边的顶部是您将要放置代码的区域。在底部，您应该可以看到即时窗口。如果缺少即时窗口，请单击Ctrl+G以显示它。下面的宏都使用即时窗口进行输出，因此您必须能够看到它

光标将位于代码区域

输入：选项显式

这指示VB编辑器检查是否定义了所有变量。下面的代码已经过测试，但这可以避免在您输入的任何代码中出现一种类型的错误

一个接一个地将下面的宏复制并粘贴到代码区域中

宏AnswerC（）、AnswerD（）、Answer（E）、AnswerF1（）和AnswerF2（）在运行前需要进行一些修改。宏中的指令

要运行宏，请将光标放在宏中，然后按F5

访问前两个文件夹级别

顶级文件夹为文件夹类型。所有子文件夹都是MAPIFolder类型。除了作为访问子文件夹的一种方式外，我从未尝试过访问顶层

AnswerA（）访问Outlook Exchange数据库，并将顶级文件夹的名称输出到即时窗口

Sub AnswerA()

  Dim InxIFLCrnt As Integer
  Dim TopLvlFolderList As Folders

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

  For InxIFLCrnt = 1 To TopLvlFolderList.Count
    Debug.Print TopLvlFolderList(InxIFLCrnt).Name
  Next

End Sub

AnswerB（）输出顶级文件夹及其直接子文件夹的名称

Sub AnswerB()

      Dim InxIFLCrnt As Integer
      Dim InxISLCrnt As Integer
      Dim SndLvlFolderList As MAPIFolder
      Dim TopLvlFolderList As Folders

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

      For InxIFLCrnt = 1 To TopLvlFolderList.Count
        Debug.Print TopLvlFolderList(InxIFLCrnt).Name
        Set SndLvlFolderList = TopLvlFolderList.Item(InxIFLCrnt)
        For InxISLCrnt = 1 To SndLvlFolderList.Folders.Count
          Debug.Print "   " & SndLvlFolderList.Folders(InxISLCrnt).Name
        Next
      Next

End Sub

AnswerB（）的问题是孩子们可以生孩子，可以生到任何深度。您需要能够找到一个特定的文件夹，无论其深度如何

查找名为f的

Sub AnswerC1()

  ' This routine wants a folder.  It does nothing but display its name. 

  Dim FolderNameTgt As String
  Dim FolderTgt As MAPIFolder

  ' The names of each folder down to the one required separated
  ' by a character not used in folder names.
  ' ##############################################################
  ' Replace "Personal Folders|MailBox|Inbox" with the name
  ' of one of your folders.  If you use "|" in your folder names,
  ' pick a different separator and change the call of AnswerC2().
  ' ##############################################################
  FolderNameTgt = "Personal Folders|MailBox|Inbox"

  Call AnswerC2(FolderTgt, FolderNameTgt, "|")
  If FolderTgt Is Nothing Then
    Debug.Print FolderNameTgt & " not found"
  Else
    Debug.Print FolderNameTgt & " found: " & FolderTgt.Name
  End If

End Sub

Sub AnswerC2(ByRef FolderTgt As MAPIFolder, NameTgt As String, NameSep As String)

  ' This routine initialises the search and finds the top level folder

  Dim InxFolderCrnt As Integer
  Dim NameChild As String
  Dim NameCrnt As String
  Dim Pos As Integer
  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 AnswerC3() to look for its children
      Call AnswerC3(TopLvlFolderList.Item(InxFolderCrnt), _
                                            FolderTgt, NameChild, NameSep)
      Exit For
    End If
  Next

End Sub

Sub AnswerC3(FolderCrnt As MAPIFolder, ByRef FolderTgt As MAPIFolder, _
                                         NameTgt As String, NameSep As String)

  ' This routine finds all folders below the top level

  Dim InxFolderCrnt As Integer
  Dim NameChild As String
  Dim NameCrnt As String
  Dim Pos As Integer

  ' 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 AnswerC3(FolderCrnt.Folders(InxFolderCrnt), _
                                            FolderTgt, NameChild, NameSep)
      End If
      Exit For
    End If
  Next

End Sub

Sub AnswerD()

  Dim FolderItem As Object
  Dim FolderItemClass As Integer
  Dim FolderNameTgt As String
  Dim FolderTgt As MAPIFolder
  Dim InxAttach As Integer
  Dim InxItemCrnt As Integer

  ' ##############################################################
  ' Replace "Personal Folders|MailBox|Inbox" with the name
  ' of one of your folders.  If you use "|" in your folder names,
  ' pick a different separator and change the call of AnswerC2().
  ' ##############################################################
  FolderNameTgt = "Personal Folders|MailBox|Inbox"

  Call AnswerC2(FolderTgt, FolderNameTgt, "|")
  If FolderTgt Is Nothing Then
    Debug.Print FolderNameTgt & " not found"
  Else
    ' Display mail items, if any, within folder
    Debug.Print "Mail items within " & FolderNameTgt
    For InxItemCrnt = 1 To FolderTgt.Items.Count
      Set FolderItem = FolderTgt.Items.Item(InxItemCrnt)

      With FolderItem

        ' This code seems to avoid syncronisation errors
        FolderItemClass = 0
        On Error Resume Next
        FolderItemClass = .Class
        On Error GoTo 0

        If FolderItemClass = olMail Then
          ' Display Received date, Attachment count and Subject
          Debug.Print "  Mail item: " & InxItemCrnt
          Debug.Print "    Received=" & Format(.ReceivedTime, _
                      "ddmmmyy hh:mm:ss") & "  " & _
                      .Attachments.Count & _
                      " attachments  Subject = " & .Subject
          Debug.Print "    Sender: " & .SenderName
          With .Attachments
            ' If the are attachments display their types and names
            If .Count > 0 Then
              Debug.Print "    Attachments:"
              For InxAttach = 1 To .Count
                With .Item(InxAttach)
                  Debug.Print "       Type=";
                  Select Case .Type
                    Case olByReference
                      Debug.Print "ByRef";
                    Case olByValue
                      Debug.Print "ByVal";
                    Case olEmbeddeditem
                      Debug.Print "Embed";
                    Case olOLE
                      Debug.Print "  OLE";
                  End Select
                  Debug.Print "  DisplayName=" & .DisplayName
                End With
              Next
            End If
          End With
        End If
      End With
    Next InxItemCrnt
  End If

End Sub

Sub AnswerE()

  ' Output any Text or HTML bodies found within specified folder

  Dim FolderItem As Object
  Dim FolderItemClass As Integer
  Dim FolderNameTgt As String
  Dim FolderTgt As MAPIFolder
  Dim FileSystem As Object
  Dim FileSystemFile As Object
  Dim HTMLBody As String
  Dim InxAttach As Integer
  Dim InxItemCrnt As Integer
  Dim PathName As String
  Dim TextBody As String

  ' ##############################################################
  ' Replace "Personal Folders|MailBox|Inbox" with the name
  ' of one of your folders.  If you use "|" in your folder names,
  ' pick a different separator and change the call of AnswerC2().
  ' The folder you pick must have at least one mail item with an
  ' HTML body for this macro to do anything.
  ' ##############################################################
  FolderNameTgt = "Personal Folders|MailBox|Inbox"

  Call AnswerC2(FolderTgt, FolderNameTgt, "|")
  If FolderTgt Is Nothing Then
    Debug.Print FolderNameTgt & " not found"
    Exit Sub
  End If

  ' ####################################################################
  ' The following is an alternative method of accessing a default folder
  ' such as Inbox. This statement would replace the code above.
  ' Set FolderTgt = CreateObject("Outlook.Application"). _
  '            GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
  ' ####################################################################

  ' Extract bodies if found

  Set FileSystem = CreateObject("Scripting.FileSystemObject")

  ' ##############################################################
  ' Replace "C:\Email\" with the name of one of your folders 
  ' ##############################################################
  PathName = "C:\Email\"

  For InxItemCrnt = 1 To FolderTgt.Items.Count
    Set FolderItem = FolderTgt.Items.Item(InxItemCrnt)

    With FolderItem

      ' This code seems to avoid syncronisation errors
      FolderItemClass = 0
      On Error Resume Next
      FolderItemClass = .Class
      On Error GoTo 0

      If FolderItemClass = olMail Then
        HTMLBody = Trim(.HTMLBody)
        If HTMLBody <> "" Then
          ' Save HTML body to disc.  The file name is of the form
          ' BodyNNN.html where NNN is a a sequence number.  
          ' First True in CreateTextFile => overwrite existing file.
          ' Second True => Unicode format
          Set FileSystemFile = FileSystem.CreateTextFile(PathName & _
                   "Body" & Right("00" & InxItemCrnt, 3) & _
                               ".html", True, True)
          FileSystemFile.Write HTMLBody
          FileSystemFile.Close
        End If
        TextBody = Trim(.Body)
        If HTMLBody <> "" Then
          ' Save text body to disc.  The file name is of the form
          ' BodyNNN.txt where NNN is a a sequence number.
          Set FileSystemFile = FileSystem.CreateTextFile(PathName & _
                   "Body" & Right("00" & InxItemCrnt, 3) & _
                               ".txt", True, True)
          FileSystemFile.Write TextBody
          FileSystemFile.Close
        End If
      End If
    End With

  Next InxItemCrnt

End Sub

 Sub AnswerF1()

   Dim xlApp As Excel.Application
   Dim ExcelWkBk As Excel.Workbook
   Dim FileName As String
   Dim PathName As String

  ' ##############################################################
  ' Replace "C:\Email\" with the name of one of your folders
  ' Replace "MyWorkbook.xls" with the your name for the workbook
  ' ##############################################################
  PathName = "C:\Email\"
  FileName = "MyWorkbook.xls"

  Set xlApp = Application.CreateObject("Excel.Application")
  With xlApp
    .Visible = True         ' This slows your macro but helps during debugging
    Set ExcelWkBk = xlApp.Workbooks.Add
    With ExcelWkBk

      ' Add Excel VBA code to update workbook here

      .SaveAs FileName:=PathName & FileName
      .Close
    End With
    .Quit
  End With
End Sub
Sub AnswerF2()

  Dim xlApp As Excel.Application
  Dim ExcelWkBk As Excel.Workbook
  Dim FileName As String
  Dim PathName As String

  ' ##############################################################
  ' Replace "C:\Email\" with the name of one of your folders
  ' Replace "MyWorkbook.xls" with the your name for the workbook
  ' ##############################################################
  PathName = "C:\Email\"
  FileName = "MyWorkbook.xls"

  Set xlApp = Application.CreateObject("Excel.Application")
  With xlApp
    .Visible = True         ' This slows your macro but helps during debugging
    Set ExcelWkBk = xlApp.Workbooks.Open(PathName & FileName)
    With ExcelWkBk

      ' Add Excel VBA code to update workbook here

      .Save
      .Close
    End With
  End With
End Sub

' Constants allow you alter the sequence of columns in your workbook without
' having to change your code.  Replace the 1, 2 and 3 in these statements
' and the job is done.
' !!! Constants must be above any subroutines and functions.

Public Const ColFrom As Integer = 1
Public Const ColSubject As Integer = 2
Public Const ColSentDate As Integer = 3

Sub AnswerG()

  Dim RowNext As Integer

  ' This code goes at the top of your macro
  With Sheets("Sheet1")     '   Replace with the name of your worksheet
    ' This finds the bottom row with a value in column A.  It then adds 1 to get
    ' the number of the first unused row.
    RowNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
  End With

  ' You will have to separate your Outlook and Excel code.
  ' With Outlook
  '   Var1 = .Body
  '   Var2 = .ReceivedTime
  '   Var3 = .SenderName
  ' End With
  ' With Excel
  '   .Cell(R, C).Value = Var1
  ' End With

  With Sheets("Sheet1")     '   Replace with the name of your worksheet

    .Cells(RowNext, ColFrom).Value = "John Smith"
    .Cells(RowNext, ColSubject).Value = "Our meeting"
    With .Cells(RowNext, ColSentDate)
      .Value = Now()
      ' This format means the time is stored and I can access it but it
      'is not displayed.  Change to "mm/dd/yy" or whatever you like.
      .NumberFormat = "d mmm yy"
    End With
    RowNext = RowNext + 1   ' Ready for next loop

  End With

End Sub