Outlook项目更改重复

Question

在Outlook中,我有一个VBA脚本,它可以读取新的传入电子邮件并将一些信息保存到Excel文件中,还可以将文本正文和任何附件保存到文件夹中.现在,我想更改我的脚本,以便保存任何类别为"Blue"的电子邮件.

所以我修改了这里的一些部分,如下所示:

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

当我第一次将电子邮件更改为"Blue"时,看起来此脚本运行正常:它使用信息填充excel文件中的新行,并创建一个包含文本和附件的新文件夹.但是,再过几秒钟后,它会复制记录,以便每次保存多封电子邮件.

例如,如果我执行以下操作:

• 将"测试5"电子邮件标记为蓝色
• 标记电子邮件"测试4"后立即显示为蓝色

然后我的excel文件看起来像

+ -------- + -------- + ------------ + ------- +
| Email Id | Category | Sender       | Subject | ...
+ -------- + -------- + ------------ + ------- +
| 1        | Blue     | me@email.com | Test 5  | ...
| 2        | Blue     | me@email.com | Test 4  | ...
| 3        | Blue     | me@email.com | Test 4  | ...
| 4        | Blue     | me@email.com | Test 4  | ...
| 5        | Blue     | me@email.com | Test 5  | ...
+ -------- + -------- + ------------ + ------- +

但我只想让它一次显示这些变化,如下所示:

+ -------- + -------- + ------------ + ------- +
| Email Id | Category | Sender       | Subject | ...
+ -------- + -------- + ------------ + ------- +
| 1        | Blue     | me@email.com | Test 5  | ...
| 2        | Blue     | me@email.com | 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