自動將特定電子郵件從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等。 ..

我w生病也勸你移動電子郵件到子文件夾，你另存爲TXT ...

Item.Move Subfolder

CODE修訂

---

---

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