如何在Outlook 2016规则中替换“以脚本运行”功能？

Question

我在Outlook中有一些“脚本”模块已被禁用，因为我们的系统中已经删除了“以脚本运行”选项。我已经向IT团队提出异议，但由于存在安全风险而未获得批准。因此，我必须找到另一种方式去做我曾经做过的事情。

我每周从自动化报告系统收到数百封电子邮件，并根据需要将它们过滤到文件夹和其他应用程序以供其他用户使用。我已经探讨了NewMailItems选项作为替代方案，但我不知道如何执行各种子例程，并将文件重定位功能作为规则的一部分。一个典型的规则会将电子邮件重定位到一个文件夹，将其标记为已读，然后通过脚本处理附件，然后关闭。

我怀疑我现在需要在VBA中编写完整的规则来做同样的事情，但是我在文件处理方面的经验很薄弱，而且我正在试验中损坏/丢失一些文件。

这就是我曾经作为通用文件的一个例子运行。还有其他人可以使用单元号码过滤器，并将附件指向船队特定的文件夹进行归档（VBA代码更长）。还有其他人在关闭前启动Excel电子表格并合并数据。我的同事也运行这段代码，并且有一些开销被剥离（文件夹存在测试等），所以如果我们离开了，数据流不会中断，脚本也不会重复条目（我只是那些写和分享它）。数据的处理是可以理解的，它正在捕获它，我需要帮助。

“为脚本运行”文件处理的活动项目的例子：

Public Sub saveAVMAttachtoDisk(itm As Outlook.MailItem) 

'Prepare variables 
Dim objAtt As Outlook.Attachment 

'Identify destination folders: 
'Engineering AVM Daily Fault folder is as follows: 
    '\\Dc3fap002\Transit Engineering\Reliability MDBF\AVM\Daily Reports\ 
Dim saveFolder1 As String 
    saveFolder1 = "\\Dc3fap002\groups$\Transit Engineering\Reliability MDBF\AVM\Daily Reports\" 

'Engineering AVM Oil Pressure Analysis folder is as follows: 
    '\\Dc3fap002\Transit Engineering\Reliability MDBF\AVM\Daily Reports\ 
Dim saveFolder2 As String 
    saveFolder2 = "\\Dc3fap002\groups$\Transit Engineering\Project Management\Fluid Life Oil Analysis\AVM Oil Pressure Study\AVM Data\" 

Dim dateFormat 
    dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd H-mm") 

'Save file 
    For Each objAtt In itm.Attachments 
    'Saves each Daily Fault Summary Report 
      If InStr(objAtt.DisplayName, "OC Transpo - Daily Fault Summary Report") Then 
       objAtt.SaveAsFile saveFolder1 & "\" & objAtt.DisplayName 
      End If 

     'Saves each Oil Pressure File with the date and time (to prevent overwriting) 
      If InStr(objAtt.DisplayName, "Engine Oil Pressure") Then 
      objAtt.SaveAsFile saveFolder2 & "\" & dateFormat & " " & objAtt.DisplayName 
      End If 

     'Clears the Attachment for the purposes of the loop 
      Set objAtt = Nothing 
    Next 

End Sub 

我已经尝试用下面的NewMailItem检测代码，但我扰数据进错了文件夹，我不小心删除/在我试用一个试用版时覆盖了一些（没有安装所有的安全和错误处理代码）。这是从未经调整的原始代码：https://www.slipstick.com/developer/processing-incoming-e-mails-with-macros/

我认为这是我需要的，我只需要采取行动，那么（调用另一个程序），而不是“回声出来”，在调试脚本。

Option Explicit 
Private objNS As Outlook.NameSpace 
Private WithEvents objNewMailItems As Outlook.Items 

Private Sub Application_Startup() 

Dim objMyInbox As Outlook.MAPIFolder 

Set objNS = Application.GetNamespace("MAPI") 
Set objMyInbox = objNS.GetDefaultFolder(olFolderInbox) 
Set objNewMailItems = objMyInbox.Items 
Set objMyInbox = Nothing 
End Sub 


Private Sub objNewMailItems_ItemAdd(ByVal Item As Object) 
'Ensure we are only working with e-mail items 
If Item.Class <> olMail Then Exit Sub 

Debug.Print "Message subject: " & Item; .Subject 
Debug.Print "Message sender: " & Item; .SenderName & " (" & Item; .SenderEmailAddress & ")"; 
End Sub 

我怀疑我缺少一个小概念元素，因此您的经验和建议将不胜感激。我相信我不会孤单，因为其他组织在关闭通向潜在恶意软件的大门时，会削减Outlook中的“以脚本运行”选项。

Answer 1

itm在运行脚本代码是ItemAdd代码中的项目。

以下所有三条建议都是等效的。

建议1 - 重复使用按原样运行脚本代码。

Private Sub objNewMailItems_ItemAdd(ByVal Item As Object) 
    'Ensure we are only working with e-mail items 
    If Item.Class <> olMail Then Exit Sub 

    saveAVMAttachtoDisk item 

End Sub 

建议2 - 将itm设置为等于item，所以在包含的脚本代码中没有变化。

Private Sub objNewMailItems_ItemAdd(ByVal Item As Object) 

    'Ensure we are only working with e-mail items 
    If Item.Class <> olMail Then Exit Sub 

    dim itm as mailitem 
    set itm = item 

    'Prepare variables 
    Dim objAtt As Outlook.Attachment 

    'Identify destination folders: 
    'Engineering AVM Daily Fault folder is as follows: 
    '\\Dc3fap002\Transit Engineering\Reliability MDBF\AVM\Daily Reports\ 
    Dim saveFolder1 As String 
    saveFolder1 = "\\Dc3fap002\groups$\Transit Engineering\Reliability MDBF\AVM\Daily Reports\" 

    'Engineering AVM Oil Pressure Analysis folder is as follows: 
    '\\Dc3fap002\Transit Engineering\Reliability MDBF\AVM\Daily Reports\ 
    Dim saveFolder2 As String 
    saveFolder2 = "\\Dc3fap002\groups$\Transit Engineering\Project Management\Fluid Life Oil Analysis\AVM Oil Pressure Study\AVM Data\" 

    Dim dateFormat 
    dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd H-mm") 

    'Save file 
    For Each objAtt In itm.Attachments 
     'Saves each Daily Fault Summary Report 
     If InStr(objAtt.DisplayName, "OC Transpo - Daily Fault Summary Report") Then 
      objAtt.SaveAsFile saveFolder1 & "\" & objAtt.DisplayName 
     End If 

     'Saves each Oil Pressure File with the date and time (to prevent overwriting) 
     If InStr(objAtt.DisplayName, "Engine Oil Pressure") Then 
      objAtt.SaveAsFile saveFolder2 & "\" & dateFormat & " " & objAtt.DisplayName 
     End If 

     'Clears the Attachment for the purposes of the loop 
     Set objAtt = Nothing 
    Next 

End Sub 

建议3 - 与项目替换ITM的情况下

Private Sub objNewMailItems_ItemAdd(ByVal Item As Object) 

'Ensure we are only working with e-mail items 
If Item.Class <> olMail Then Exit Sub 

'Prepare variables 
Dim objAtt As Outlook.Attachment 

'Identify destination folders: 
'Engineering AVM Daily Fault folder is as follows: 
'\\Dc3fap002\Transit Engineering\Reliability MDBF\AVM\Daily Reports\ 
Dim saveFolder1 As String 
saveFolder1 = "\\Dc3fap002\groups$\Transit Engineering\Reliability MDBF\AVM\Daily Reports\" 

'Engineering AVM Oil Pressure Analysis folder is as follows: 
'\\Dc3fap002\Transit Engineering\Reliability MDBF\AVM\Daily Reports\ 
Dim saveFolder2 As String 
saveFolder2 = "\\Dc3fap002\groups$\Transit Engineering\Project Management\Fluid Life Oil Analysis\AVM Oil Pressure Study\AVM Data\" 

Dim dateFormat 
dateFormat = Format(item.ReceivedTime, "yyyy-mm-dd H-mm") 

'Save file 
For Each objAtt In item.Attachments 
    'Saves each Daily Fault Summary Report 
    If InStr(objAtt.DisplayName, "OC Transpo - Daily Fault Summary Report") Then 
     objAtt.SaveAsFile saveFolder1 & "\" & objAtt.DisplayName 
    End If 

    'Saves each Oil Pressure File with the date and time (to prevent overwriting) 
    If InStr(objAtt.DisplayName, "Engine Oil Pressure") Then 
     objAtt.SaveAsFile saveFolder2 & "\" & dateFormat & " " & objAtt.DisplayName 
    End If 

    'Clears the Attachment for the purposes of the loop 
    Set objAtt = Nothing 
Next 

End Sub