将电子邮件附件移动到 Outlook 中的子文件夹

Posted 2023-03-15

【中文标题】将电子邮件附件移动到 Outlook 中的子文件夹

【英文标题】：Move attachments that are emails to a subfolder in Outlook

【发布时间】：2017-05-20 07:14:34

【问题描述】：

每天从 [e-mail] 收到一封电子邮件，主题为“电子邮件”，附件为电子邮件（最多 20 个附件，每个 15kb）。

我正在尝试将这些附件移动到我的 Outlook 收件箱中名为“Extra”的子文件夹中。

我在修改旧代码时遇到问题。我想它来自这里。 Const attPath As String = "Mailbox/Extra".

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

        'From specified user with specified subject
        If (Msg.SenderName = "teresa") And _
          (Msg.Subject = "emails") 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. 
            Const attPath As String = "Mailbox/Extra"

            ' 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

ProgramExit:
    Exit Sub

ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit

End Sub

【问题讨论】：

所以你不是发邮件的，是你收的？你能分享你目前的代码吗？

看看这个例子。 ***.com/a/29910853/4539709

我是收到电子邮件的人。上面链接中的代码看起来比我的要干净得多，但它只会将电子邮件从一个文件夹移动到另一个文件夹，我已经可以这样做了，但是它提取了我遇到问题的电子邮件中的附件。

现在有点困惑，想把附件移到哪里？本地文件夹？或新电子邮件？您也可以在问题结束之前发布您当前的代码

我每天收到一次的电子邮件有附件，但那些是电子邮件。我只是想提取电子邮件，而不是单击所有电子邮件并将它们拖到我收件箱中的不同文件夹中，以便它们自动传输。我不是很懂 VBA，所以我什至不知道是否可以使用 attachment.movetofolder。

【参考方案1】：

您似乎无法将附件移动到 Outlook 中的另一个文件夹，除非事先将它们保存在本地。

希望以下代码对您有用...

在这个 Outlook 会话中：

Private WithEvents InboxItems As Outlook.Items

Private Sub Application_Startup()
    On Error Resume Next
    Set InboxItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub InboxItems_ItemAdd(ByVal Item As Object)
    On Error Resume Next
    If TypeName(Item) = "MailItem" Then Call MoveAttachments(Item)
End Sub

在一个模块中：

Function MoveAttachments(ByVal Item As Object)
    
    Const AttachmentFolder As String = "Extra"
    
    Dim ThisNameSpace As Outlook.NameSpace: Set ThisNameSpace = Application.GetNamespace("MAPI")
    Dim Inbox As Outlook.MAPIFolder: Set Inbox = ThisNameSpace.GetDefaultFolder(olFolderInbox)
    
    On Error Resume Next
        Dim AttFolder As Outlook.Folder: Set AttFolder = Inbox.Folders(AttachmentFolder)
        If AttFolder Is Nothing Then Set AttFolder = Inbox.Parent.Folders(AttachmentFolder)
        If AttFolder Is Nothing Then Exit Function
    On Error GoTo ExitSub
    
    With Item   'From specified user with specified subject
        If .SenderName = "teresa" And .Subject = "emails" And .Attachments.Count >= 1 Then
            Call MoveAttachedMessages(Item, AttFolder, False)
        End If
    End With
        
ExitSub:
End Function

Function MoveAttachedMessages(ByVal Item As Object, _
    AttachmentFolder As Outlook.Folder, _
    Optional DeleteMoved As Boolean)

    If IsMissing(DeleteMoved) Then DeleteMoved = False

    Dim TempPath As String: TempPath = Environ("temp") & "\OLAtt-" & Format(Now(), "yyyy-mm-dd") & "\"
    If Dir(TempPath, vbDirectory) = "" Then MkDir TempPath

    Dim ThisNameSpace As Outlook.NameSpace: Set ThisNameSpace = Application.GetNamespace("MAPI")
    Dim AttItems As Outlook.Attachments, AttItem As Outlook.Attachment
    Dim msgItem As Outlook.MailItem

    ' Save attachments
    On Error Resume Next

    Set AttItems = Item.Attachments
    For Each AttItem In AttItems
        If LCase(Right(AttItem.FileName, 4)) = ".msg" Then
            AttItem.SaveAsFile TempPath & AttItem.FileName
            Set msgItem = ThisNameSpace.OpenSharedItem(TempPath & AttItem.FileName)
            'Set msgItem = Outlook.CreateItemFromTemplate(TempPath & AttItem.FileName)
            If Not msgItem Is Nothing Then
                msgItem.UnRead = True
                msgItem.Save
                msgItem.Move AttachmentFolder
                If msgItem.Saved = True And DeleteMoved = True Then
                    AttItem.Delete
                    Item.Save
                End If
            End If
        End If
    Next AttItem

    If Err.Number = 0 Then Item.UnRead = False ' Mark as Read

    If Dir(TempPath, vbDirectory) <> "" Then
        Kill TempPath & "\" & "*.*"
        RmDir TempPath
    End If
    
End Function

注意：不知道为什么，但是使用此代码无法将复制的附件标记为未读。我已经留下了代码，也许其他人可以识别问题。

感谢 Seby 发现问题；代码已更新

【讨论】：

谢谢。我很难使用函数 MoveAttachedMessages(ByVal Item As Object, _ AttachmentFolder As Outlook.Folder, _ Optional DeleteMoved As Boolean) 声明它未定义

您好 - 没有更多信息，我不确定能否提供帮助。该代码通常对我有用（尽管我取出逻辑 [If .SenderName = "teresa" And .Subject = "emails" And .Attachments.Count >= 1 Then] 来测试它）。也许这有什么问题？

撞旧线程。 @Tragamor，未读属性的设置失败，因为 msgItem 已被保存和移动。如果将 [msgItem.UnRead = True] 移到 [msgItem.Save] 之前，效果很好。

【参考方案2】：

这是我的文件夹代码

-Inbox
--Folder1
---SubFolder1
---SubFolder2
--Folder2

.. 在 Folder1 中搜索带有附件的电子邮件并移入特定的子文件夹

Sub MoveAttachmentToFolder(Item As Outlook.MailItem)

'Dichiarazione
Dim OutApp As Outlook.Application
Dim Namespace As Outlook.Namespace
Dim Mfolder As Outlook.MAPIFolder
Dim Folder As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim UserFolder As Outlook.MAPIFolder
Dim UserUserFolder As Outlook.MAPIFolder
Dim olkAtt As Outlook.Attachment

Set OutApp = New Outlook.Application
Set Namespace = OutApp.GetNamespace("MAPI")
Set Root = Namespace.Folders("root")
Set Folder = Root.Folders("Inbox")
Set SubFolder = Folder.Folders("Folder1")
Set UserFolder = SubFolder.Folders("SubFolder1")
Debug.Print UserFolder.Name

    'Check each attachment
    For Each olkAtt In Item.Attachments
        'If the attachment's file name with 202627
         If InStr(LCase(olkAtt), "202627") > 0 Then
            'Move the message to SubFolder "DL IT CG SKY-DE PRJ"
            Item.Move SubFolder.Folders("SubFolder1")
            'No need to check any of this message's remaining attachments
            Exit For
        End If
    Next
    Set olkAtt = Nothing
End Sub

【讨论】：

.msg 附件将保存在 Outlook 中，而不是项目中。 "将电子邮件附件移动到 Outlook 中的子文件夹"