0

我在 Outlook 中有许多“脚本”模块已被禁用，因为“作为脚本运行”选项已在我们的系统中删除。

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

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
4

1 回答 1

0

itm 在运行一个脚本代码是ItemAdd 代码中的item。

以下三个建议都是等效的。

建议 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 - 将其设置为等于 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 - 用 item 替换 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
于 2017-08-17T20:27:05.303 回答