Outlook项目更改重复

在Outlook中，我有一个VBA脚本 ，它读取新的传入电子邮件，并将一些信息保存到Excel文件，并将文本正文和任何附件保存到文件夹中。 现在，我想改变我的脚本，以便保存任何类别为“蓝色”的电子邮件。

所以我修改了这里的一些部分：

Public WithEvents objMails As Outlook.Items Private Sub Application_Startup() Set objMails = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items End Sub Private Sub objMails_ItemChange(ByVal Item As Object) If Item.Class = olMail And Item.Categories = "Blue" Then Set objMail = Item Else Exit Sub End If .... 

代码的其余部分包括有关保存的细节，其中没有一个是从我以前的工作脚本中更改的，但为了完整起见，我将其包括在内。

 ... 'Specify the Excel file which you want to auto export the email list 'You can change it as per your case strRootFolder = "N:\Outlook Excel VBA\" strExcelFile = "EmailBookTest3.xlsx" 'Get Access to the Excel file On Error Resume Next Set objExcelApp = GetObject(, "Excel.Application") If Error <> 0 Then Set objExcelApp = CreateObject("Excel.Application") End If Set objExcelWorkBook = objExcelApp.Workbooks.Open(strRootFolder & strExcelFile) Set objExcelWorkSheet = objExcelWorkBook.Sheets("Sheet1") 'Get the next empty row in the Excel worksheet nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.Count).End(xlUp).Row + 1 'Specify the corresponding values in the different columns strColumnB = objMail.Categories strColumnC = objMail.SenderName strColumnD = objMail.SenderEmailAddress strColumnE = objMail.Subject strColumnF = objMail.ReceivedTime strColumnG = objMail.Attachments.Count 'Add the vaules into the columns objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1 objExcelWorkSheet.Range("B" & nNextEmptyRow) = strColumnB objExcelWorkSheet.Range("C" & nNextEmptyRow) = strColumnC objExcelWorkSheet.Range("D" & nNextEmptyRow) = strColumnD objExcelWorkSheet.Range("E" & nNextEmptyRow) = strColumnE objExcelWorkSheet.Range("F" & nNextEmptyRow) = strColumnF 'Fit the columns from A to E objExcelWorkSheet.Columns("A:F").AutoFit 'Save the changes and close the Excel file objExcelWorkBook.Close SaveChanges:=True 'EmailBody Dim FileSystem As Object Dim FileSystemFile As Object Set FileSystem = CreateObject("Scripting.FileSystemObject") FileSystem.CreateFolder (strRootFolder & "\" & nNextEmptyRow - 1) Set FileSystemFile = FileSystem.CreateTextFile(strRootFolder & "\" & nNextEmptyRow - 1 & _ "\Email_" & nNextEmptyRow - 1 & ".txt", True, True) FileSystemFile.Write Trim(objMail.Body) FileSystemFile.Close 'Attachments Dim ItemAttachment As Attachment For Each ItemAttachment In objMail.Attachments ItemAttachment.SaveAsFile strRootFolder & "\" & nNextEmptyRow - 1 & "\" & _ ItemAttachment.FileName Next ItemAttachment End Sub 

当我第一次把电子邮件改为“蓝色”时，看起来这个脚本完美地工作了：它在excel文件中用信息填充一个新行，并创build一个包含文本和附件的新文件夹。 但是，再过几秒之后，它会复制logging，以便每个电子邮件都被保存多次。

例如，如果我执行以下操作：

• 将电子邮件“testing5”标记为蓝色
• 马克电子邮件“testing4”后立即蓝色

那么我的Excel文件看起来像

 + -------- + -------- + ------------ + ------- + | Email Id | Category | Sender | Subject | ... + -------- + -------- + ------------ + ------- + | 1 | Blue | [e-mail] | Test 5 | ... | 2 | Blue | [e-mail] | Test 4 | ... | 3 | Blue | [e-mail] | Test 4 | ... | 4 | Blue | [e-mail] | Test 4 | ... | 5 | Blue | [e-mail] | Test 5 | ... + -------- + -------- + ------------ + ------- + 

但我只想让它一次显示这些变化，就像这样：

 + -------- + -------- + ------------ + ------- + | Email Id | Category | Sender | Subject | ... + -------- + -------- + ------------ + ------- + | 1 | Blue | [e-mail] | Test 5 | ... | 2 | Blue | [e-mail] | Test 4 | ... + -------- + -------- + ------------ + ------- + 

任何想法可能会发生什么？ 谢谢

更新：

同样的事情发生在我所有的类别。

我正在使用Outlook版本14.0.7180.5002（64位）

Answer 1

如果ItemChange事件触发，它会触发，除非您更改ItemChange后面的代码，这是不太可能的。

但是，如果你不能改变它，你总是可以控制它。 我试图用LastModificationTime控制它与当前时间相比，但触发有时是即时的，所以它不能很好地工作。 然后，我试图控制项目的UserProperties ，我花了一些时间来弄清楚，但最终它的工作。 我的代码适用于“蓝色类别”，所以如果它适合您，可以将其更改为“蓝色”。

使用以下内容：

 Dim myProp As Outlook.UserProperty Set myProp = Item.UserProperties.Find("MyProcess") If Item.Categories <> "Blue Category" Then Debug.Print "Removing Blue Category and reseting Item Property" Set myProp = Item.UserProperties.Add("MyProcess", olText) myProp = True Exit Sub End If If TypeOf Item Is Outlook.MailItem And Item.Categories = "Blue Category" Then If myProp Is Nothing Then Debug.Print "Categorizing Item to Blue Category" Set myProp = Item.UserProperties.Add("MyProcess", olText) myProp = False Set objMail = Item ElseIf myProp = True Then Debug.Print "Re-categorizing Item to Blue Category" Set myProp = Item.UserProperties.Add("MyProcess", olText) myProp = False Set objMail = Item Else Debug.Print "Item has already been processed" Exit Sub End If Else Debug.Print "Wrong category or action, exiting sub." Exit Sub End If 

而不是这个：

 If Item.Class = olMail And Item.Categories = "Blue" Then Set objMail = Item Else Exit Sub End If 

Answer 2

你在使用这些电子邮件的状态标志？ 如果你不使用这些东西你可以做一些懒东西

 Private Sub objMails_ItemChange(ByVal Item As Object) If Item.Class = olMail And Item.Categories = "Blue" Then Set objMail = Item If objMail.FlagStatus = olFlagComplete Then Exit Sub objMail.FlagStatus = olFlagComplete Else Exit Sub End If 

它会设置电子邮件与复选标记第一次读取与蓝色类别（并运行您的代码），然后忽略电子邮件每隔一段时间。 有更好的地方把代码放在ItemChange的第一位，但我不完全熟悉Outlook的所有事件callback。