excel - 使用 Excel VBA 将 Outlook 电子邮件从收件箱移动到基于主题行的存档子文件夹 (Outlook 365

问题描述

我使用的 Outlook 版本是通过雇主，他们使用 Outlook 365 - Microsoft Exchange(owa)。

我编写了一个脚本，在我的 Outlook 收件箱中查找包含“PHI Attrition Dashboard Terminations”的任何主题行的电子邮件。找到后，它会检查以确保这是一封尚未审核的新电子邮件并包含附件。它将电子邮件中的附件保存到共享驱动器上的文件夹并重命名文件以包含适用日期。然后，根据用户的选择，调用另一个宏来完成额外的更新。所有这部分工作完美，我遇到困难的部分是一旦调用的宏完成并返回到这个宏，我希望能够将使用过的电子邮件移动到另一个文件夹中，该文件夹保存在我的存档项目下在 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

标签： excelvbaoutlookoutlook-web-app

excel - 使用 Excel VBA 将 Outlook 电子邮件从收件箱移动到基于主题行的存档子文件夹 (Outlook 365 - Microsoft Exchange)

问题描述

解决方案

推荐阅读