Автосохранение вложений Outlook VBA

Question

Я играл с приведенным ниже кодом в попытке сохранить файлы, которые мы получаем ежедневно в Outlook.Кажется, код работает нормально, но когда я проверяю папку назначения, вложения не сохраняются.

Как изменить код, чтобы сохранить вложения в указанной папке?

 Private WithEvents Items As Outlook.Items

    Private Sub Application_Startup()
        Dim olApp As Outlook.Application
        Dim objNS As Outlook.NameSpace
        Set olApp = Outlook.Application
        Set objNS = olApp.GetNamespace("MAPI")
        Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
    End Sub

    Private Sub Items_ItemAdd(ByVal item As Object)

    On Error GoTo ErrorHandler

        'Only act if it's a MailItem
        Dim Msg As Outlook.MailItem
        If TypeName(item) = "MailItem" Then
            Set Msg = item

        'Change variables to match need. Comment or delete any part unnecessary.
            If (Msg.SenderName = "made-up-email@some_domain.com") And _
            (Msg.Subject = "Test") And _
            (Msg.Attachments.Count >= 1) Then

        'Set folder to save in.
        Dim olDestFldr As Outlook.MAPIFolder
        Dim myAttachments As Outlook.Attachments
        Dim Att As String

        'location to save in.  Can be root drive or mapped network drive.
        Const attPath As String = "T:\London File3 Group\Client Reporting\Test"


        ' save attachment
           Set myAttachments = item.Attachments
        Att = myAttachments.item(1).DisplayName
        myAttachments.item(1).SaveAsFile attPath & Att

        ' mark as read
          Msg.UnRead = False
          End If
          End If
          End Sub

Answer 1

Этот код должен работать, что-то, чего вы, возможно, не сделали, добавило это к объекту ThisOutlookSession.Не добавляйте в стандартный модуль.

Private WithEvents InboxItems As Outlook.Items
Const attPath As String = "T:\London File3 Group\Client Reporting\Test\"

Private Sub Application_Startup()
    Dim outlookApp As Outlook.Application: Set outlookApp = Outlook.Application
    Dim objectNS As Outlook.NameSpace: Set objectNS = outlookApp.GetNamespace("MAPI")
    Set InboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub InboxItems_ItemAdd(ByVal Item As Object)
    Dim Msg             As Outlook.MailItem: Set Msg = Item
    Dim olDestFldr      As Outlook.MAPIFolder
    Dim myAttachments   As Outlook.Attachments
    Dim Filename        As String

    If Not TypeName(Msg) = "MailItem" Then Exit Sub
    If (Msg.SenderName = "made-up-email@some_domain.com") And (Msg.Subject = "Test") And (Msg.Attachments.Count >= 1) Then
        Set myAttachments = Item.Attachments
        Filename = myAttachments.Item(1).DisplayName
        myAttachments.Item(1).SaveAsFile attPath & Filename
        Msg.UnRead = False
    End If
End Sub