Question

在Outlook中，我有一个VBA Script来读取新传入的电子邮件，并将一些信息保存到Excel文件中，并将文本正文和任何附件保存到文件夹中。现在，我想更改我的脚本，以便保存任何类别为＆＃34; Blue＆＃34;的电子邮件。

所以我已经修改了这里的某些部分：

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

当我第一次将电子邮件更改为＆＃34; Blue＆＃34;时，似乎此脚本运行正常：它使用信息填充excel文件中的新行，并创建一个包含文本和附件的新文件夹。但是，再过几秒钟后，它会复制记录，以便每次保存多封电子邮件。

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

Mark Email＆＃34; Test 5＆＃34;如蓝色
在标记电子邮件＆＃34;测试4＆＃34;之后立即如蓝色

然后我的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

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的事件回调。

Outlook项目更改重复

2 个答案: