Outlookのサブフォルダに添付ファイルを自動的に移動

Question

受信した添付ファイルをInboxからOutlook Inbox/Subfolderに移動するにはどうすればよいですか？ドラッグアンドドロップすることなくこれをやろうとしています。

abc@xyz.comから電子メールを受信します。件名には電子メール添付ファイル（電子メール添付ファイルあり）が添付されています（添付ファイルはそれぞれ15kbで最大20件）。 私は、添付ファイルが自動的に私の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.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 

注：いいえ理由は分かりますが、このコードを使用すると、コピーした添付ファイルを未読としてマークすることはできません。私はコードに残しました、多分他の誰かが問題を識別することができます。