vba - Outlook VBA 电子邮件自动保存

Question

我正在使用下面的代码在电子邮件到达时自动保存它们。我遇到的问题是只保存在默认收件箱中的电子邮件。我进行了一些搜索并尝试了一些调整，但我是 VBA 的新手，似乎还没有任何效果。

    Option Explicit

    Public Enum olSaveAsTypeEnum
      olSaveAsTxt = 0
      olSaveAsRTF = 1
      olSaveAsMsg = 3
    End Enum

    Private WithEvents Items As Outlook.Items

    Private Const MAIL_PATH As String = "C:\Users\xxxxx\My Documents\Emails\"

    Private Sub Application_Startup()
      Dim Ns As Outlook.NameSpace

      Set Ns = Application.GetNamespace("MAPI")
      Set Items = Ns.GetDefaultFolder(olFolderInbox).Items
    End Sub

    Private Sub Items_ItemAdd(ByVal Item As Object)
      If TypeOf Item Is Outlook.MailItem Then
        SaveMailAsFile Item, olSaveAsMsg, MAIL_PATH
      End If
    End Sub

    Private Sub SaveMailAsFile(oMail As Outlook.MailItem, _
      eType As olSaveAsTypeEnum, _
      sPath As String _
    )
      Dim dtDate As Date
      Dim sName As String
      Dim sFile As String
      Dim sExt As String

      Select Case eType
        Case olSaveAsTxt: sExt = ".txt"
        Case olSaveAsMsg: sExt = ".msg"
        Case olSaveAsRTF: sExt = ".rtf"
        Case Else: Exit Sub
      End Select

      sName = oMail.Subject
      ReplaceCharsForFileName sName, "_"

      dtDate = oMail.ReceivedTime
      sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
        vbUseSystem) & Format(dtDate, "-hhnnss", _
        vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & sExt

      oMail.SaveAs sPath & sName, eType
    End Sub

    Private Sub ReplaceCharsForFileName(sName As String, _
      sChr As String _
    )
      sName = Replace(sName, "/", sChr)
      sName = Replace(sName, "\", sChr)
      sName = Replace(sName, ":", sChr)
      sName = Replace(sName, "?", sChr)
      sName = Replace(sName, Chr(34), sChr)
      sName = Replace(sName, "<", sChr)
      sName = Replace(sName, ">", sChr)
      sName = Replace(sName, "|", sChr)
    End Sub

我已经在下面尝试了这个改变。

Private Sub Application_Startup()
  Dim Ns As Outlook.NameSpace

  Set Ns = Application.GetNamespace("MAPI")
  Set Items = Ns.Folders.Item("Inbox").Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.MailItem Then
    SaveMailAsFile Item, olSaveAsMsg, MAIL_PATH
  End If
End Sub

但是我得到一个找不到对象的错误。

Answer 1

我昨晚弄明白了。抱歉这么晚才回来。我将下面的脚本与收到消息后应用的规则一起使用。我将规则放在列表的顶部以确保它们得到保存。到目前为止一直锻炼得很好。

Public Sub saveEmailtoDisk(itm As Outlook.MailItem)

    Dim saveFolder As String
    Dim sName As String
    Dim from As String
    saveFolder = "C:\Users\xxxxxx\My Documents\Emails\"
    sName = itm.Subject
    from = itm.SenderName
    ReplaceCharsForFileName sName, "_"
    itm.SaveAs saveFolder & Format$(itm.CreationTime, "(mm-dd-yy)-") & from & "-" & sName & ".msg", olMSG
End Sub
Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
    sName = Replace(sName, "/", sChr)
    sName = Replace(sName, "\", sChr)
    sName = Replace(sName, ":", sChr)
    sName = Replace(sName, "?", sChr)
    sName = Replace(sName, Chr(34), sChr)
    sName = Replace(sName, "<", sChr)
    sName = Replace(sName, ">", sChr)
    sName = Replace(sName, "|", sChr)
End Sub