Use Excel VBA to move an Outlook Email from Inbox to a SubFolder of Archive based on Subject Line (Outlook 365 - Microsoft Exchange)

Question

The version of Outlook I'm using is via employer which they use Outlook 365 - Microsoft Exchange(owa).

I have written a script that looks for emails in my Outlook Inbox with any subject line containing "PHI Attrition Dashboard Terminations". Once found, it checks to make sure it is a new email that hasn't already been reviewed and contains an attachment. It saves the attachment on the email to a folder on shared drive & renames file to include applicable date. Then, based on user selection, it calls another macro to complete additional updates. All of this part works perfectly, the part that I'm having difficulty with is once the called macro completes and returns to this macro, I want to be able to move the email that was used to another folder that is saved under my Archived items in Outlook. I can't figure out a way to reference an Archived Subfolder. I've included my code below, as well as a screenshot of my Outlook File Hierarchy. I'm trying to move the email from my Inbox to the "File Updates" folder under Archive.

For the line Set SubFolder = olNamespace.GetDefaultFolder(olFolderInbox).Folders("File Updates"), I've used this format, I've tried SubFolder = Inbox.Folders("File Updates") & nothing seems to work. I keep getting error:

Current Code:

Sub CheckEmail_HRT()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Declare Outlook Objects
Dim olApp As New Outlook.Application
Dim olNamespace As Outlook.Namespace 'Same as olNs
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder

'Declare other variables
Dim filteredItems As Outlook.Items 'Same as Items
Dim itm As Object 'Same as Item
Dim strFilter As String

'Outlook Variables for email
Dim sSubj As String, dtRecvd As String 'sSubj same as strSubjec
Dim oldSubj As String, olddtRecvd As String
Dim olFileName As String, olFileType As String
Dim strFolder As String

Sheets("Job Mapping").Visible = True
Sheets("CC Mapping").Visible = True
Sheets("Site Mapping").Visible = True
Sheets("Historical Blue Recruit Data").Visible = True
Sheets("Historical HRT Data").Visible = True
Sheets("Combined Attrition Data").Visible = True

Sheets.Add Before:=Sheets(1)

'Designate ECP Facilities Model file as FNAME
myPath = ThisWorkbook.Path
MainWorkbook = ThisWorkbook.Name

Range("A1").Select
ActiveCell.FormulaR1C1 = myPath

'designate file path for Attrition Files
    FacModPath = Cells(1, 1).Value
    Sheets(1).Delete


'Get Outlook Instance
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set Inbox = olNamespace.GetDefaultFolder(olFolderInbox)
Set SubFolder = olNamespace.***Unsure of Code here****.Folders("File Updates")

strFilter = "@SQL=urn:schemas:httpmail:subject LIKE '%PHI  Attrition Dashboard Terminations%'"

Set filteredItems = Inbox.Items.Restrict(strFilter)

'Chec if there are any matching emails
If filteredItems.Count = 0 Then
    MsgBox "No emails found."
    GoTo ExitFor
Else
    For Each itm In filteredItems
        If itm.Attachments.Count <> 0 Then
            dtRecvd = itm.ReceivedTime
            dtRecvd = Format(dtRecvd, "mm/dd/yyyy")
            sSubj = itm.Subject
            oldSubj = Sheets("CC Mapping").Range("N2").Value
            olddtRecvd = Sheets("CC Mapping").Range("N3").Value
            olddtRecvd = Format(olddtRecvd, "mm/dd/yyyy")
            If sSubj = oldSubj And dtRecvd <= olddtRecvd Then
                    MsgBox "No new HRT data files to load."
                    GoTo ExitFor
            Else
                Workbooks(MainWorkbook).Activate
                If Sheets("CC Mapping").Visible = False Then
                    Sheets("CC Mapping").Visible = True
                End If
                Sheets("CC Mapping").Select
                Range("N2").Select
                ActiveCell.FormulaR1C1 = sSubj
                Range("N3").Select
                ActiveCell.FormulaR1C1 = dtRecvd
                For j = 1 To itm.Attachments.Count
                    olFileName = itm.Attachments.Item(1).DisplayName
                    If Right(LCase(olFileName), 4) = ".xls" Then
                        'Query if user wishes to contunue to load data
                        Answer = MsgBox("New HRT Attrition Dasboard Terminations attachment found, dated " & dtRecvd & "." & vbNewLine & "Would you like to load the new data?", vbQuestion + vbYesNo, "Confirm Next Step")
                        
                        If Answer = vbYes Then
                            olFileName = "HRT_ATTRITION_DASHBOARD_TERMS-" & Format(dtRecvd, "MM.DD.YY") & ".xls"
                            itm.Attachments.Item(1).SaveAsFile FacModPath & "\" & olFileName
                            Call HRT_Update
                        Else
                            GoTo ExitFor
                        End If
                        
                    Else
                        MsgBox "No attachment found."
                        GoTo ExitFor
                    End If
                Next j
            End If
        End If
        'Mark email as read
        itm.UnRead = False
        'Move email to SubFolder
        itm.Move SubFolder
    Next
End If

ExitFor:
    Sheets("Job Mapping").Visible = False
    Sheets("CC Mapping").Visible = False
    Sheets("Site Mapping").Visible = False
    Sheets("Historical Blue Recruit Data").Visible = True
    Sheets("Historical HRT Data").Visible = True
    Sheets("Combined Attrition Data").Visible = True

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Dmitry Streblechenko Dmitry Streblechenko · Accepted Answer · 2020-07-07T19:52:00

You were almost there - from the Inbox, go one level up to its parent, and the then to the Archive folder, and then to is child folder

set Inbox = olNamespace.GetDefaultFolder(olFolderInbox)
set InboxParent = Inbox.Parent
set Archive = InboxParent.Folders("Archive")
set DestFolder = Archive.Folders("File Updates")

Note that the Archive folder is one of the default folders, but Outlook Object Model does not expose it as such. Since the actual name can be localized, you might run into problems in the localized environments. Redemption, for example, lets you open the Archive Folder using RDOSession.GetDefaultFolder(olFolderArchive).

Use Excel VBA to move an Outlook Email from Inbox to a SubFolder of Archive based on Subject Line (Outlook 365 - Microsoft Exchange)

1 Answers