Question

正在为我们正在努力实现的目标寻找可能的解决方案。

我们收到特定电子邮件的来源很少，而按邮件标题甚至源电子邮件地址进行分类的最简单方法是

我们基本上是试图让Outlook自动将所有传入的电子邮件保存到文件中，无论是TXT还是PDF。这使我们可以访问那些文件，而不管我们是否具有连接性，即使网络，电子邮件或其他任何出现故障的地方，我们也可以轻松提取备份文件...

例如，我试图从一些类似的主题中创建宏；

    Private Sub Application_Startup()
    Dim olNs As Outlook.NameSpace
    Dim Inbox  As Outlook.MAPIFolder

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

Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        SaveMailAsFile Item ' call sub
    End If
End Sub
Public Sub SaveMailAsFile(ByVal Item As Object)

    Dim olNs As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim ItemSubject As String
    Dim NewName As String
    Dim RevdDate As Date
    Dim Path As String
    Dim Ext As String
    Dim i As Long

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items.Restrict("[Subject] = 'VVAnalyze Results'")

    Path = Environ("USERPROFILE") & "\Desktop\Backup Reports\"
    ItemSubject = Item.Subject
    RevdDate = Item.ReceivedTime
    Ext = "txt"

    For i = Items.Count To 1 Step -1
        Set Item = Items.Item(i)

        DoEvents

        If Item.Class = olMail Then
            Debug.Print Item.Subject ' Immediate Window
            Set SubFolder = Inbox.Folders("Temp") ' <--- Update Fldr Name

            ItemSubject = Format(RevdDate, "YYYYMMDD-HHNNSS") _
                                                    & " - " & _
                                            Item.Subject & Ext

            ItemSubject = FileNameUnique(Path, ItemSubject, Ext)

            Item.SaveAs Path & ItemSubject, olTXT
            Item.Move SubFolder
        End If
    Next

    Set olNs = Nothing
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set Items = Nothing

End Sub


'// Check if the file exists
Private Function FileExists(FullName As String) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    If fso.FileExists(FullName) Then
        FileExists = True
    Else
        FileExists = False
    End If

    Exit Function
End Function

'// If the same file name exist then add (1)
Private Function FileNameUnique(Path As String, _
                               FileName As String, _
                               Ext As String) As String
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(FileName) - (Len(Ext) + 1)
    FileName = Left(FileName, lngName)

    Do While FileExists(Path & FileName & Chr(46) & Ext) = True
        FileName = Left(FileName, lngName) & " (" & lngF & ")"
        lngF = lngF + 1
    Loop

    FileNameUnique = FileName & Chr(46) & Ext

    Exit Function
End Function

这似乎不起作用，或者我不知道如何使它起作用……尽管这对我们来说是完美的解决方案。因此，我在考虑Outlook插件，但立即陷入困境，甚至无法获取该插件，以识别出我已标记了某些邮件...基本上，我在寻找一些提示或n00bs的良好指南，我可以使用它们使它起作用。

为什么我们需要这个？好吧，虽然我个人了解Outlook缓存甚至可以离线使用，但有些人仍坚持要在物理硬盘上备份某种文件。

是的，我知道我可以手动选择这些文件并通过拖放来创建副本...不幸的是，这还不够...

非常感谢你们的任何帮助。

我知道例如存在。 https://www.techhit.com/messagesave/screenshots.html

因为GDPR等等等等...很难让这个想法在我的公司中被接受...

将继续研究并在这里发布我的发现。

Answer 1

您可以使用此代码，将其粘贴到ThisOutlookSession模块中。

要在不重新启动Outlook的情况下测试此代码示例，请在Application_Startup过程中单击，然后单击“运行”。

Option Explicit
Private WithEvents Items As Outlook.Items

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

  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String

  enviro = CStr(Environ("USERPROFILE"))

  sName = Item.Subject
  ReplaceCharsForFileName sName, "_"

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

' use My Documents for older Windows.
    sPath = enviro & "\Documents\"
  Debug.Print sPath & sName
  Item.SaveAs sPath & sName, olMSG

  End If

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

有关更多信息，请参考此链接：

Save all incoming messages to the hard drive

Save outlook mail automatically to a specified folder

Outlook新电子邮件自动导出到文件

1 个答案: