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