自动将特定的电子邮件从Outlook导出到文本文件 [英] Automatically export specific emails to text file from Outlook
问题描述
我正在尝试使用VBA脚本自动将具有特定主题的所有传入电子邮件导出到文本文件,然后再使用Python脚本进行解析.下面的代码在大多数情况下都有效,但是会随机跳过一些传入的电子邮件.
I am trying to use a VBA script to automatically export all incoming emails with a specific subject to text files that I will then parse with a Python script. The code below works for the most part, but it will randomly skip some of the emails come in.
我没有找到任何原因,而且每天都不会跳过来自同一发件人的电子邮件,这会有所不同.
I haven't found any reason as to why this is, and it doesn't skip emails from the same sender each day, it varies.
如果这很重要,那么在30分钟左右的时间内我们会收到大约20-30封电子邮件.我希望对此有所帮助.
We have about 20-30 emails coming in during a 30 minute period or so if that matters. I'd love some help with this.
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
推荐答案
您的代码对我来说还好,所以我不确定您是在处理代码时用新的邮件覆盖保存的电子邮件还是一次收到许多电子邮件一个并跳过另一个...
Your code looks okay to me so I am not sure if your overwriting your saved emails with new one or your getting to many emails at once while the code is processing one and skipping the other...
我已经修改了您的代码以在收件箱中循环,并添加了Function以在文件已经存在时创建新文件名...
I have modified your code to loop in your Inbox and added Function to create new file name if the file already exist...
如果您在1秒钟内收到10封电子邮件,该功能将创建FileName(1).txt, FileName(2).txt
,依此类推...
if you receive 10 email in 1 second, the function will create FileName(1).txt, FileName(2).txt
and so on...
我还将建议您在另存为txt ...时将电子邮件移动到子文件夹中.
I will also advise you to move the emails to subfolder as you SaveAs txt...
代码已更新
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
这篇关于自动将特定的电子邮件从Outlook导出到文本文件的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!