'How to reference a Subfolder of Archive?
I'm using 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 to a folder on a shared drive & renames the file to include applicable date.
Then, based on user selection, it calls another macro to complete additional updates.
All of this works.
Once the called macro completes and returns, I want to move the email 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 used
SubFolder = Inbox.Folders("File Updates")
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
Solution 1:[1]
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 (I am its author), for example, lets you open the Archive Folder using RDOSession.GetDefaultFolder(olFolderArchive)
without specifying the Archive folder name:
olFolderArchive = 9031
set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Application.Session.MAPIOBJECT
set archiveFolder = Session.GetDefaultFolder(olFolderArchive)
MsgBox archiveFolder.Items.Count
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
Solution | Source |
---|---|
Solution 1 |