如何引用存档的子文件夹？

Question

我正在使用 Outlook 365 - Microsoft Exchange(owa)。

我编写了一个脚本，用于在我的 Outlook 收件箱中查找任何主题行包含“PHI Attrition Dashboard Terminations”的电子邮件。
一旦找到，它会检查以确保它是一封新的电子邮件，尚未审查并包含附件。它将附件保存到共享驱动器上的文件夹并重命名文件以包括适用日期。
然后，根据用户的选择，它会调用另一个宏来完成额外的更新。
所有这些都有效。

调用的宏完成后 returns，我想将电子邮件移动到保存在 Outlook 中“已归档项目”下的另一个文件夹。

我想不出引用存档子文件夹的方法。我在下面包含了我的代码，以及我的 Outlook 文件层次结构的屏幕截图。我正在尝试将电子邮件从我的收件箱移至存档下的“文件更新”文件夹。

换行

Set SubFolder = olNamespace.GetDefaultFolder(olFolderInbox).Folders("File Updates")

我用过

SubFolder = Inbox.Folders("File Updates")

我得到：

当前代码：


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

Answer 1

您快到了 - 从收件箱向上一级到其父级，然后到 Archive 文件夹，然后是子文件夹

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

请注意，存档文件夹是默认文件夹之一，但 Outlook 对象模型不会将其公开。由于实际名称可以本地化，您可能运行在本地化环境中遇到问题。 Redemption (I am its author), for example, lets you open the Archive Folder using RDOSession.GetDefaultFolder(olFolderArchive) 未指定存档文件夹名称：

olFolderArchive = 9031
set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Application.Session.MAPIOBJECT
set archiveFolder = Session.GetDefaultFolder(olFolderArchive)
MsgBox archiveFolder.Items.Count

如何引用存档的子文件夹？

How to reference a Subfolder of Archive?

excel

outlook

vba

outlook-web-app