运行脚本的 VBA Outlook 规则未完成答案

【问题标题】：VBA Outlook rule to Run Script is not completing运行脚本的 VBA Outlook 规则未完成
【发布时间】：2014-06-20 03:41:40
【问题描述】：

这个宏/脚本无法完全通过电子邮件规则运行，我遇到了问题

我有一个 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

【问题讨论】：

标签： vba outlook

【解决方案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

【讨论】：