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

自动保存Outlook附件VBA

1 个答案: