自動保存 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