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

Question

每天从 abc@xyz.com 收到一封电子邮件，主题为“电子邮件”，附件为电子邮件（最多 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

Answer 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 发现问题；代码已更新

Answer 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