Outlook VBA Macro to move mail from subfolder to subfolder

问题

I am currently encountering a slight issue with running a VBA script.

Sub MovePathErrors(Item As Outlook.MailItem)

If Item.Attachments.Count > 0 Then

Dim attCount As Long
Dim strFile As String
Dim sFileType As String

attCount = Item.Attachments.Count

For i = attCount To 1 Step -1
      strFile = Item.Attachments.Item(i).FileName

      sFileType = LCase$(Right$(strFile, 4))

    Select Case sFileType
        Case ".ber"
    ' do something if the file types are found
    ' this code moves the message
      Item.Move (Session.GetDefaultFolder(olFolderInbox).Folders(".PathErrors"))

   ' stop checking if a match is found and exit sub
       GoTo endsub
      End Select
  Next i

End If

Basically the above code moves all the mail items with attachments that contain a .ber file type from my inbox folder to the '.PathErrors' subfolder - this works perfectly.

However what I want to do is move mails from a different sub folder '.AllPathMails' to '.PathErrors' if they contain an attachment with a .ber file type.

I tried the following code but it doesn't work:

Sub MovePathErrors(Item As Outlook.MailItem)

If Item.Attachments.Count > 0 Then

Dim attCount As Long
Dim strFile As String
Dim sFileType As String

attCount = Item.Attachments.Count

For i = attCount To 1 Step -1
      strFile = Item.Attachments.Item(i).FileName

      sFileType = LCase$(Right$(strFile, 4))

    Select Case sFileType
        Case ".ber"
    ' do something if the file types are found
    ' this code moves the message
      Item.Move (Session.GetDefaultFolder(".AllPathMails").Folders(".PathErrors"))

   ' stop checking if a match is found and exit sub
       GoTo endsub
      End Select
  Next i

End If

Am I doing something wrong here? I believe it could be the 'Session.GetDefaultFolder' part that's faulty?

回答1:

This will work if

the two folders are named .AllPathMails and .PathErrors

AND

They are SubFolders of your Inbox and depicted below:

 Option Explicit
 Sub MoveEmailsBetweenFoldersDependingOnAttachmentType()

      Dim AllPathMailsFolderList As Outlook.MAPIFolder
      Set AllPathMailsFolderList = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(".AllPathMails")

      Dim CurrentItem As Object
      Dim CurrentAttachment As Outlook.Attachment
      Dim AttachmentName As String
      Dim AttachmentFileType As String

      For Each CurrentItem In AllPathMailsFolderList.Items

           If CurrentItem.Attachments.Count > 0 Then

                For Each CurrentAttachment In CurrentItem.Attachments

                     AttachmentName = CurrentAttachment.FileName
                     AttachmentFileType = LCase$(Right$(AttachmentName, 4))

                     If AttachmentFileType = ".ber" Then
                          'CurrentItem.Move (GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(".PathErrors"))
                     End If

                Next CurrentAttachment

           End If

      Next CurrentItem

 End Sub

来源：https://stackoverflow.com/questions/37133599/outlook-vba-macro-to-move-mail-from-subfolder-to-subfolder

标签

vba

outlook