Question

我根据主题行制定了以下代码，以便将电子邮件的附件保存到映射的网络驱动器。但是，当新电子邮件进入时，Outlook 2010（xp OS）中的规则不起作用。它不会将其保存到指定位置。当我手动运行规则时，它工作得很好。

我启用了所有宏。重启Outlook没有变化。我在运行时已经提示了宏。它会在新电子邮件进入时提示。我点击启用无保存，没有保存的错误。

Public Sub SaveAttachments2(mail As Outlook.MailItem)
On Error GoTo GetAttachments_err
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim f As String
Dim strSubject As String
Dim w As Integer

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)

For Each Item In Inbox.Items
   strSubject = Item.Subject
    f = strSubject
    Rem MkDir ("Z:\OPERATIO\AS400_Report\" & f)
    For Each Atmt In Item.Attachments
        FileName = "Z:\OPERATIO\AS400_Reports\" & f & "\" & Atmt.FileName
        Atmt.SaveAsFile FileName
        i = i + 1


    'commented out and added rule option to delete the item
    Next Atmt
    'Item.Delete

    GetAttachments_exit:
     Set Atmt = Nothing
     Set Item = Nothing
     Set ns = Nothing
     Exit Sub

    GetAttachments_err:
     MsgBox "An unexpected error has occurred." _
     & vbCrLf & "Please note and report the following information." _
     & vbCrLf & "Macro Name: SaveAttachments2" _
     & vbCrLf & "Error Number: " & Err.Number _
     & vbCrLf & "Error Description: " & Err.Description _
     , vbCritical, "Error!"
     Resume GetAttachments_exit
    'added next because of compile error
    Next
    End Sub

Answer 1

您无法通过简单地添加（邮件为Outlook.MailItem）来更改独立VBA。

Public Sub SaveAttachments2(mail As Outlook.mailItem)

    Dim Atmt As attachment
    Dim FileName As String
    Dim f As String

    f = Trim(mail.Subject) ' Removes spaces at ends. This is a big problem.

    On Error Resume Next
    MkDir ("Z:\OPERATIO\AS400_Report\" & f) ' Creates a folder if it does not exist

    On Error GoTo GetAttachments_err

    For Each Atmt In mail.Attachments
       FileName = "Z:\OPERATIO\AS400_Reports\" & f & "\" & Atmt.FileName

        Atmt.SaveAsFile FileName
        ' Fails on subjects with illegal characters.
        ' For example when RE: and FW: in the subject the folder cannot be created.

    Next Atmt

GetAttachments_exit:
     Exit Sub

GetAttachments_err:
     MsgBox "An unexpected error has occurred." _
     & vbCrLf & "Please note and report the following information." _
     & vbCrLf & "Macro Name: SaveAttachments2" _
     & vbCrLf & "Error Number: " & Err.Number _
     & vbCrLf & "Error Description: " & Err.Description _
     , vbCritical, "Error!"
     Resume GetAttachments_exit

End Sub

如果非法字符导致创建文件夹出现问题，请参阅此处Save mail with subject as filename

当有新电子邮件进入时，规则不会运行

1 个答案: