收件箱规则，当电子邮件速率增加时发送警报

Question

我每天都会收到数百个自动警报（例如CPU /内存峰值，SQL块之类的警报）。但是，通常，当这些警报出现时，我无能为力。我只关心警报数量激增的情况，因为那是异常的。至少我确实将它们放在单独的文件夹中，但这仍然令人分心，因为我必须始终注意未读的电子邮件号码。

当我在N分钟内收到发件人姓名的电子邮件数量超过X时，是否可以通过某种方式提醒我？

使用Outlook，Office 365

我尝试寻找Outlook加载项，但这对Google来说是个很难回答的问题。我对VBA知之甚少，但不足以让我开始学习。

Answer 1

基本上，您必须运行一个计时器才能定期运行扫描程序以查看收件箱中收到的电子邮件数量。在计时器触发的事件处理程序（通常称为Tick）中，您可以使用Items类的Find / FindNext或Restrict方法。

最简单，最快的方法是创建VBA宏。请参阅Getting started with VBA in Office和Using Visual Basic for Applications in Outlook文章以快速入门。

以下文章可以帮助您在描述Outlook项目的方法之上编写所需的算法：

• How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
• How To: Use Restrict method to retrieve Outlook mail items from a folder
• Advanced search in Outlook programmatically: C#, VB.NET

要定期运行计时器，可以使用SetTimer函数。 有关示例代码，请参见Outlook VBA - Run a code every half an hour。

Public Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
 Public Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long

 Public TimerID As Long, TimerSeconds As Single
 Dim Counter As Long

 ' Start Timer
 Sub StartTimer()
    ' Set the timer for 1 second
    TimerSeconds = 1
    TimerID = SetTimer(0&, 0&, TimerSeconds * 1000&, AddressOf TimerProc)
 End Sub

 ' End Timer
 Sub EndTimer()
    On Error Resume Next
    KillTimer 0&, TimerID
 End Sub

 Sub TimerProc(ByVal HWnd As Long, ByVal uMsg As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)       
   Debug.Print Now
   ' call your code here
 End Sub

Answer 2

我从您的问题中假设，您希望有人已经为您的问题制定了解决方案。也许他们有，但我认为他们不太可能将解决方案发布给其他人。我认为您将必须开发自己的解决方案。我开发的方法与Eugene的方法大不相同。在我们之间，我们提供一些有趣的想法供您选择。

我认为所需的VBA并不特别先进。您可能已经足够了解，尤其是要学习两个答案。如果没有，我将从Excel VBA开始。我未能找到我喜欢的Outlook VBA教程，但看到了一些看起来不错的Excel VBA教程。我喜欢书。我参观了一个好的图书馆，看了几个Excel VBA入门手册，并借用了最有前途的在家尝试。

您还需要了解Outlook对象模型。 Excel VBA教程将教您有关工作簿，工作表，范围，单元格等的信息。对于Outlook，您需要了解存储，文件夹，邮件项目，日历项目等。就像我说的那样，我找不到我喜欢的Outlook VBA教程，也不喜欢我购买的推荐量很高的书。我通过实验学习了Outlook VBA。尤金（Eugene）在回答中包含了解释，我将在我的解释中包含解释。希望我们之间能够给您足够的开始。您可能很幸运地找到一本同时解释主题A，B和C的帖子。我发现最好逐个查找主题，然后编写将它们组合在一起的实验宏。如果您无法通过实验宏，请将其发布在此处，并附上您要实现的目标以及出了什么问题的说明；您几乎肯定会得到帮助。

为模拟您的问题，我选择了四个供应商，这些供应商经常向我发送电子邮件，以开发和测试我的监控代码。您说您使用规则将这些电子邮件移动到单独的文件夹，这对我来说是个好主意。规则提供了多种分类，可以通过这些分类选择电子邮件，而我收集到的则可以从输入流中选择这些电子邮件。规则还提供了一些数字处理选项。您已使用“移至文件夹”。另一个是“运行脚本”。在这种情况下，脚本是具有特定结构的Outlook VBA宏。我很有信心，我可以创建一个宏来执行您所需的监视。但是，存在一个问题：Outlook在将电子邮件移动到新文件夹之前先运行宏。这不是一个大问题，但这意味着您无法使用规则移动电子邮件。您必须获得宏才能移动电子邮件，这并不困难。

我为摘要如下的每个供应商创建了一条规则：

Apply this rule after the message arrives
from Xxxxx
  and on this computer only
run Project1.Yyyyy
  and stop processing more rules

“ Xxxxx”是供应商的名称，“ Yyyyy”是将处理电子邮件的宏的名称。我是家庭用户，因此“仅在这台计算机上”对我没有影响，但可能对您有帮助。没有“并停止处理更多规则”，您将收到消息，指出找不到电子邮件，因为规则X移动了电子邮件，然后规则Y在收件箱中找不到它。

宏Yyyyy的格式为：

Public Sub Yyyyy(ByRef itm As MailItem)

  Call CountAndWarn("test folders\Xxxxx", itm, 2, 180, 3, 600)

End Sub

宏的名称并不重要。显然，如果规则说运行宏Yyyyy，则必须有一个宏Yyyyy，但是Yyyyy的值并不重要。我是用Outlook的供应商名称来命名宏的，但您大概必须用电子邮件类型来命名它们。

第一行Public Sub Yyyyy(ByRef itm As MailItem)的格式或多或少是固定的，以便按规则运行宏。第一个参数必须是MailItem。还有一些我从未使用过的可选参数。

CountAndWarn是我编写的用于处理所有这些电子邮件的宏。它至少具有四个参数，但如果对特定类型的电子邮件有所帮助，则可以具有六个或八个或更多。

“测试文件夹\ Xxxxx”标识了要将电子邮件移动到的文件夹。

如果您查看Outlook文件夹窗格，您将在左边缘看到至少一个名称。在其下方但被缩进的是系统文件夹，例如收件箱，已删除邮件，已发送邮件和发件箱。在任何系统文件夹下，您可以具有专用子文件夹。您还可以拥有与系统文件夹相同级别的私人文件夹，其中任何一个文件夹都可以具有任意深度的子文件夹和子子文件夹。左边缘的名称标识商店。存储是Outlook在其中存储电子邮件，约会，任务等的文件。您将至少有一个存储电子邮件的商店。您可能还拥有共享的商店，这些商店可以对整个组织公开，也可以对团队或部门不公开。您可以根据需要在许多私人商店中购物。

在我的系统上，每个电子邮件地址有一个商店（我有三个），还有几个私人商店。在“测试文件夹\ Xxxxx”中，“测试文件夹”是我用于实验的私有存储的名称。在“测试文件夹”中，我创建了四个文件夹，每个我监视的供应商一个。在每个文件夹中，都有一个“旧”子文件夹，稍后将对其进行解释。因此，在我的文件夹窗格中，我有一个部分如下所示：

test folders
  Xxxxx
    Old
  Wwwww
    Old
 Vvvvv
    Old
  Uuuuu
    Old

正如我所说，“ test folder \ Xxxxx”标识一个文件夹。此字符串的格式为“ StoreName \ FolderName \ SubFolderName \ SubSubFolderName…”。我已经将文件夹放在实验商店中了；您可能已将文件夹放置在主存储中。您可以将它们放在有写权限的任何地方。此字符串必须指定以商店名称开头的文件夹的全名。您的名字可能是：“ YourMainStore \ Inbox \ CPU Spikes”和“ YourMainStore \ Inbox \ SQL Blocks”。

返回到Call CountAndWarn("test folders\Xxxxx", itm, 2, 180, 3, 600)。

第二个参数itm将电子邮件传递到CountAndWarn，以便将电子邮件移至指定的文件夹。

其余参数是一对或多对整数，其中第一对是电子邮件计数，第二对是分钟数。我的参数列表表示希望在以下情况下得到警告

：

• 最近180分钟内有2封电子邮件来自供应商Xxxxx
• 最近600分钟内有3封来自供应商Xxxxx的电子邮件到达

我每天不会收到很多此类电子邮件，因此我的计数很低而且期限很长。您的人数将大大增加，而您的月经将会大大缩短。

我不知道您是否希望监视不同的时间段，但是几乎没有多余的代码可用于多个时间段，因此我将其包括在内。您必须至少具有一个计数和一个期间，但是您可以根据需要拥有任意数量的额外对。如果您有多个句点，则它们必须按升序排列，最长的句末要持续。

CountCountWarn宏执行以下操作：

• 找到命名的目标文件夹，例如“ test folder \ Xxxxx”。
• 找到相应的“旧”文件夹，例如“ test folder \ Xxxxx \ Old”。
• 将电子邮件移动到目标文件夹
• 统计每个时期的电子邮件。如果电子邮件的时间早于上一个周期的结束时间，请将其移至“旧”文件夹，这样就不会在每次收到新电子邮件时都对其进行检查。
• 如果任何计数超过其期限内的最大值，则会显示如下消息框。

如果您想要的只是即时警告一天中的每个高峰，那么这些宏可能是理想的。缺陷包括：

• 当峰值持续出现时，系统会提醒您每一封新电子邮件。
• 不会在深夜警告您。

没有记录就无法解决第一个缺陷。例如，宏CountAndWarn会对文件夹中的电子邮件进行计数并报告较高的计数。它没有记录它在十秒前收到最后一封电子邮件时就警告您当前的峰值。将记录保存在文本文件中并不难，但是您将需要考虑哪些记录可以帮助您分析峰值。

在深夜，您需要对旧电子邮件进行分析。当前宏仅统计最近X分钟内的电子邮件。查看昨晚的电子邮件将涉及自昨天关闭后每X分钟内对电子邮件进行计数。该分析可能不需要任何晦涩的VBA，但需要进行一些仔细的设计。

如果您对以下宏没有任何了解，请返回问题：

Option Explicit
Public Sub Argos(ByRef itm As MailItem)

  Call CountAndWarn("test folders\Argos", itm, 2, 180, 3, 600)

End Sub
Public Sub Guardian(ByRef itm As MailItem)

  Call CountAndWarn("test folders\Guardian", itm, 1, 600, 2, 1200, 3, 1800)

End Sub
Public Sub Amazon(ByRef itm As MailItem)

  Call CountAndWarn("test folders\Amazon", itm, 2, 600)

End Sub
Public Sub Wayfair(ByRef itm As MailItem)

  Call CountAndWarn("test folders\Wayfair", itm, 2, 600)

End Sub
Sub CountAndWarn(ByVal FldrDestName As String, ByRef itm As MailItem, _
                 ParamArray CountPeriod() As Variant)

  Dim CountsCrnt() As Long
  Dim CountsTgt() As Long
  Dim FldrDest As Outlook.Folder
  Dim FldrDestNamePart() As String
  Dim FldrOld As Outlook.Folder
  Dim InxC As Long
  Dim InxCS As Long
  Dim InxFldrName As Long
  Dim InxItem As Long
  Dim LB As Long
  Dim Msg As String
  Dim NumCounts As Long
  Dim Periods() As Date
  Dim Recent As Boolean
  Dim Warn As Boolean

  FldrDestNamePart = Split(FldrDestName, "\")
  LB = LBound(FldrDestNamePart)   ' Should be zero but just in case

  ' Set FldrDest to Store
  On Error Resume Next
  Set FldrDest = Session.Folders(FldrDestNamePart(LB))
  On Error GoTo 0
  If FldrDest Is Nothing Then
    Debug.Assert False  ' Store doesn't exist
    Exit Sub
  End If

  ' Set FldrDest to destination folder
  For InxFldrName = LB + 1 To UBound(FldrDestNamePart)
    On Error Resume Next
    Set FldrDest = FldrDest.Folders(FldrDestNamePart(InxFldrName))
    On Error GoTo 0
    If FldrDest Is Nothing Then
      Debug.Assert False  ' Subfolder doesn't exist
      Exit Sub
    End If
  Next

  'Set FldrOld to the Old folder for FldrDest
  On Error Resume Next
  Set FldrOld = FldrDest.Folders("Old")
  On Error GoTo 0
  If FldrOld Is Nothing Then
    Debug.Assert False  ' No subfolder "Old" within destination folder
    Exit Sub
  End If

  ' Move new email from Inbox to FldrDest
  itm.Move FldrDest

  'Debug.Print "CountPeriod";
  'For InxCS = LBound(CountSince) To UBound(CountSince)
    'Debug.Print " " & CountSince(InxCS);
  'Next
  'Debug.Print

  ' Determine number of counts and periods in CountPeriod
  ' No check for an odd number of values in CountPeriod
  NumCounts = (UBound(CountPeriod) - LBound(CountPeriod) + 1) / 2

  ' Size arrays according to number of counts
  ReDim CountsCrnt(1 To NumCounts)
  ReDim CountsTgt(1 To NumCounts)
  ReDim Periods(1 To NumCounts)

  ' Initialise arrays and convert periods in minutes to a time
  InxC = 1
  For InxCS = LBound(CountPeriod) To UBound(CountPeriod) Step 2
    CountsTgt(InxC) = CountPeriod(InxCS)
    CountsCrnt(InxC) = 0
    Periods(InxC) = DateAdd("n", -CountPeriod(InxCS + 1), Now())
    InxC = InxC + 1
  Next

  'Debug.Print FldrDest.Name
  'Debug.Print "New " & itm.ReceivedTime
  For InxItem = FldrDest.Items.Count To 1 Step -1
    With FldrDest.Items(InxItem)
      'Debug.Print .ReceivedTime & " ";
      Recent = False
      For InxC = 1 To NumCounts
        If .ReceivedTime > Periods(InxC) Then
          CountsCrnt(InxC) = CountsCrnt(InxC) + 1
          Recent = True
          Exit For
        End If
      Next
    End With
    If Recent Then
      'Debug.Print "Index " & InxC & " Count " & CountsCrnt(InxC)
    Else
      'Debug.Print "Old: Moved"
      FldrDest.Items(InxItem).Move FldrOld
    End If
  Next

  ' Check counts to see if warning required
  Warn = False
  For InxC = 1 To NumCounts
    If InxC > 1 Then
      ' Add in count of more recent emails
      CountsCrnt(InxC) = CountsCrnt(InxC) + CountsCrnt(InxC - 1)
      'Debug.Print "CountsCrnt(InxC) := " & CountsCrnt(InxC)
    End If
    If CountsCrnt(InxC) >= CountsTgt(InxC) Then
      Warn = True
    End If
  Next

  If Warn Then
    ' At least one count in excess of maximum
    Msg = "Warning. Emails in " & FldrDestName
    For InxC = 1 To NumCounts
      Msg = Msg & vbLf & CountsCrnt(InxC) & " since " & Format(Periods(InxC), "ddd h:mm:ss")
    Next
    Call MsgBox(Msg, vbOKOnly)
  End If

End Sub