Outlook VBA 电子邮件自动保存

Outlook VBA Email Autosave

提问by 93Akkord

I'm using the code below to automatically save emails as they arrive. The issue I have is that emails that are only in the default inbox are saved. I've searched a bit and tried a few tweaks, but I'm new to VBA and nothing has seemed to work yet.

我正在使用下面的代码在电子邮件到达时自动保存它们。我遇到的问题是只保存在默认收件箱中的电子邮件。我搜索了一下并尝试了一些调整，但我是 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

I have tried this change below.

我在下面尝试了这种更改。

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

But I get an object not found error.

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

采纳答案by 93Akkord

Its been a while and I can't believe I never marked this question complete, but I'm glad I didn't. I actually did find the best solution a little while ago and it does resemble a what niton said.

已经有一段时间了，我不敢相信我从未将这个问题标记为完整，但我很高兴我没有。不久前我确实找到了最好的解决方案，它确实类似于 niton 所说的。

First create a class with the name cFolderItemsand the following code:

首先创建一个名为cFolderItems的类和以下代码：

Option Explicit

Private WithEvents pFolderItems As Outlook.Items

Public Property Set FolderItems(sFolder As Outlook.Items)
    Set pFolderItems = sFolder
End Property

Public Property Get FolderItems()
    Set FolderItems = pFolderItems
End Property

Private Sub pFolderItems_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        ' Save email function here
    End If
End Sub

Then in a separate module named whatever put the following code:

然后在一个名为 what 的单独模块中放入以下代码：

Option Explicit

Public pFolderEvents As Collection

Public oNS As Namespace
Public oInbox As folder

Dim eHandler As cFolderItems

Public Sub PopulateFolders()
    If Not SetCheck(pFolderEvents) Then
        Set pFolderEvents = New Collection
        Set oNS = Application.GetNamespace("MAPI")
        Set oInbox = oNS.GetDefaultFolder(olFolderInbox)

        RecursiveFolders oInbox
        TrashCleaner
    End If
End Sub

Function RecursiveFolders(rFolder As Folder) As folder
    Dim oSubFolder As Folder

    Set eHandler = New cFolderItems
    Set eHandler.FolderItems = rFolder.Items

    pFolderEvents.Add eHandler
    For Each oSubFolder In rFolder.Folders
        DoEvents
        RecursiveFolders oSubFolder
    Next
End Function

Function SetCheck(oObject) As Boolean
    If oObject Is Nothing Then
        SetCheck = False
    Else
        SetCheck = True
    End If
End Function

Function TrashCleaner()
    Set oNS = Nothing
    Set oInbox = Nothing
End Function

And in ThisOutlookSession

在这个OutlookSession中

Option Explicit    

Private Sub Application_Startup()
    PopulateFolders
End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    ' Just in case the objects become unset
    PopulateFolders
End Sub

回答by 93Akkord

I was able to figure out last night. Sorry for getting back so late. I'm using the script below with a rule that applies after receiving a message. I placed the rule at the top of the list to ensure they get saved. Has been working out great so far.

我昨晚能弄清楚。抱歉这么晚才回来。我正在使用下面的脚本以及在收到消息后适用的规则。我将规则放在列表的顶部以确保它们得到保存。到目前为止一直很好。

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

回答by niton

If you recursively loop you would resave old mail as well. This might be okay as the old file would be overwritten not duplicated.

如果您递归循环，您也会重新保存旧邮件。这可能没问题，因为旧文件将被覆盖而不是重复。

You could try separate code for each subfolder.

您可以为每个子文件夹尝试单独的代码。

Private WithEvents ItemsSub1 As Outlook.Items

Private WithEvents ItemsSub1 作为 Outlook.Items

Set ItemsSub1 = Ns.GetDefaultFolder(olFolderInbox).Folders("Sub1").Items

设置 ItemsSub1 = Ns.GetDefaultFolder(olFolderInbox).Folders("Sub1").Items

Private Sub ItemsSub1_ItemAdd(ByVal Item As Object)

Private Sub ItemsSub1_ItemAdd(ByVal Item As Object)