自动将特定电子邮件从 Outlook 导出到文本文件

Question

我正在尝试使用 VBA 脚本自动将具有特定主题的所有传入电子邮件导出到文本文件，然后我将使用 Python 脚本对其进行解析。下面的代码大部分都可以工作，但它会随机跳过一些进来的电子邮件。

我没有找到任何原因来解释为什么会这样，而且它不会每天跳过来自同一发件人的电子邮件，它会有所不同。

如果重要的话，我们会在 30 分钟左右的时间内收到大约 20-30 封电子邮件。我很想得到一些帮助。

Private Sub Items_ItemAdd(ByVal Item As Object)
Dim strSubject As String
strSubject = Item.Subject
  If TypeOf Item Is Outlook.MailItem And strSubject Like "VVAnalyze Results" Then
    SaveMailAsFile Item
  End If
End Sub

Private Sub SaveMailAsFile(oMail As Outlook.MailItem)
  Dim dtDate As Date
  Dim sName As String
  Dim sFile As String
  Dim sExt As String

  sPath = "C:\Users\ltvstatus\Desktop\Backup Reports\"
  sExt = ".txt"
  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, olSaveAsTxt
End Sub

Answer 1

您的代码对我来说看起来不错，所以我不确定您是用新的电子邮件覆盖已保存的电子邮件，还是在代码处理一封邮件并跳过另一封邮件时一次收到多封电子邮件...

我已修改您的代码以在您的收件箱中循环并添加函数以在文件已存在时创建新文件名...

如果您在 1 秒内收到 10 封电子邮件，该函数将创建 FileName(1).txt, FileName(2).txt 等等...

我还会建议您将电子邮件移动到子文件夹，因为您将 SaveAs txt...

Item.Move Subfolder

代码更新

---

---

Option Explicit
Private WithEvents Items As Outlook.Items
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