VBA的Outlook运行规则的脚本是没有完成

Question

我有不完全通过电子邮件规则

我有一个Outlook规则，查找一封电子邮件，主题然后将运行此宏/脚本的麻烦发送到子文件夹的电子邮件会运行脚本，将电子邮件附件移动到C驱动器上的文件夹中，然后从子文件夹中删除原始电子邮件

似乎所有内容都安装正确，安全性正常，规则外的宏它只是规则不运行脚本，这里是我正在使用的脚本

Sub Get_SOH_All(MyMail As MailItem) 

On Error GoTo SaveAttachmentsToFolder_err 


Dim ns As NameSpace 
Dim Inbox As MAPIFolder 
Dim SubFolder As MAPIFolder 
Dim item As Object 
Dim Atmt As Attachment 
Dim FileName As String 
Dim i As Integer 
Dim varResponse As VbMsgBoxResult 


Set ns = GetNamespace("MAPI") 
Set Inbox = ns.GetDefaultFolder(olFolderInbox) 
Set SubFolder = Inbox.Folders("DATA DUMP") ' Enter correct subfolder name. 
i = 0 

If Len(Dir("c:\DATA DUMP\Stock On Hand", vbDirectory)) = 0 Then 
MkDir "c:\DATA DUMP\Stock On Hand" 
End If 


For Each item In SubFolder.Items 
    For Each Atmt In item.Attachments 
     If Right(Atmt.FileName, 3) = "csv" Then 


     FileName = "C:\DATA DUMP\Stock On Hand\" 
     Atmt.SaveAsFile FileName & "Stock_On_Hand_All.csv" 

     item.Delete 

      i = i + 1 
     End If 
    Next Atmt 
Next item 

SaveAttachmentsToFolder_exit: 
Set Atmt = Nothing 
Set item = Nothing 
Set ns = Nothing 
Exit Sub 

SaveAttachmentsToFolder_err: 
MsgBox "An unexpected error has occurred." _ 
    & vbCrLf & "Please note and report the following information to Jarrod Hall." _ 
    & vbCrLf & "Macro Name: GetAttachmentsSOH" _ 
    & vbCrLf & "Error Number: " & Err.Number _ 
    & vbCrLf & "Error Description: " & Err.Description _ 
    , vbCritical, "Error!" 
Resume SaveAttachmentsToFolder_exit 
End Sub 

Answer 1

脚本中的代码通常用于一个项目而不是多个项目。

邮件将被删除，因此您可以放弃移动邮件的规则部分并尝试此操作。

Sub Get_SOH_All(MyMail As MailItem) 

On Error GoTo SaveAttachmentsToFolder_err 

Dim Atmt As Attachment 
Dim FileName As String 

If Len(Dir("c:\DATA DUMP\Stock On Hand", vbDirectory)) = 0 Then 
MkDir "c:\DATA DUMP\Stock On Hand" 
End If 

For Each Atmt In MyMail.Attachments 

    If Right(Atmt.FileName, 3) = "csv" Then 
     FileName = "C:\DATA DUMP\Stock On Hand\" 
     Atmt.SaveAsFile FileName & "Stock_On_Hand_All.csv" 
     MyMail.Delete 
    End If 

Next Atmt 

SaveAttachmentsToFolder_exit: 
Set MyMail = Nothing 
Exit Sub 

SaveAttachmentsToFolder_err: 
MsgBox "An unexpected error has occurred." _ 
    & vbCrLf & "Please note and report the following information to Jarrod Hall." _ 
    & vbCrLf & "Macro Name: GetAttachmentsSOH" _ 
    & vbCrLf & "Error Number: " & Err.Number _ 
    & vbCrLf & "Error Description: " & Err.Description _ 
    , vbCritical, "Error!" 
Resume SaveAttachmentsToFolder_exit 
End Sub