將電子郵件附件移動到 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 中的另一個文件夾，而無需事先將它們保存在本地。

以下代碼應該對您有用...

在ThisOutlookSession中：

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