运行脚本的VBA Outlook规则未完成
我很抱歉,这个宏/脚本不能完全通过电子邮件规则运行 我有一个outlook规则,可以查找带有主题的电子邮件,然后将电子邮件移动到子文件夹,然后运行脚本将电子邮件附件移动到C驱动器上的文件夹,然后从子文件夹中删除原始电子邮件 一切似乎都设置正确,安全性正常,宏作为规则外的宏运行只是规则没有运行脚本,这是我使用的脚本运行脚本的VBA Outlook规则未完成,vba,outlook,Vba,Outlook,我很抱歉,这个宏/脚本不能完全通过电子邮件规则运行 我有一个outlook规则,可以查找带有主题的电子邮件,然后将电子邮件移动到子文件夹,然后运行脚本将电子邮件附件移动到C驱动器上的文件夹,然后从子文件夹中删除原始电子邮件 一切似乎都设置正确,安全性正常,宏作为规则外的宏运行只是规则没有运行脚本,这是我使用的脚本 Sub Get_SOH_All(MyMail As MailItem) On Error GoTo SaveAttachmentsToFolder_err Dim ns As N
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
脚本中的代码通常用于一个项目,而不是多个项目 邮件将被删除,因此您可以删除规则中移动邮件的部分,然后重试此操作
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