Автоматическое перемещение вложений в подпапку по прогнозу

Question

Как перенести полученные приложения с Inbox в прогноз Inbox/Subfolder. Попытка сделать это, не перетаскивая.

Электронная почта получена один раз в день с abc@xyz.com, при этом тема темы является «электронной почтой» с прикрепленными письмами (до 20 вложений по 15 кбайт каждый). Я пытаюсь, чтобы эти вложения автоматически переместились в подпапку с именем «Экстра» в моем почтовом ящике Outlook.

У меня возникли проблемы с изменением моего старого кода. Я думаю, что это происходит отсюда.

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.Save 
       msgItem.Move AttachmentFolder 
       If msgItem.Saved = True And DeleteMoved = True Then 
        AttItem.Delete 
        Item.Save 
       End If 
       msgItem.UnRead = True 
      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 

Примечание: нет то почему, но используя этот код, скопированные вложения не могут быть отмечены как непрочитанные. Я оставил в коде, может быть, кто-то еще может определить проблему.