引用收件箱的子文件夹以移动邮件

Question

我有 Outlook 2010。我收到的电子邮件具有相同的主题行，并带有要打开的 PDF。当 PDF 打开时，Adobe 询问我是否要将其添加到 Excel 响应文件中，我说是。

当 Adob​​e 询问是否要添加到响应文件时，我希望它以“好的”响应，但没有它我也能应付。在这一行：

Set SubFolder = Mailbox.Folders("Response File")

我收到一个错误：

尝试的操作失败。找不到对象。

未读电子邮件所在的子文件夹在我的收件箱下方称为“！响应文件”（不带引号）。打开 PDF 后，我想将电子邮件标记为已读，并移至另一个名为“已提取”（不带引号）的子文件夹（在收件箱下）。

Sub GetAttachments()
  On Error GoTo GetAttachments_err
  Dim ns As NameSpace
  Dim Inbox As MAPIFolder
  Dim SubFolder As MAPIFolder
  Dim Item As Object
  Dim Atmt As Attachment
  Dim FileName As String
  Dim i As Integer

  Set ns = GetNamespace("MAPI")
  Set Inbox = ns.GetDefaultFolder(olFolderInbox)
  Set Mailbox = Inbox.Parent
  Set SubFolder = Mailbox.Folders("!Response File")
  i = 0

  'check if there is any mail in the folder'
  If SubFolder.Items.Count = 0 Then
    MsgBox "There are no messages in the folder.", vbInformation, _
    "Nothing Found"
    Exit Sub
  End If

  'Check each message and save the attachment'
  If SubFolder.Items.Count > 0 Then
    For Each Item In SubFolder.Items
      If Item.UnRead = True Then
        For Each Atmt In Item.Attachments
          FileName = "C:\Users\abrupbac\Desktop\Response Emails\" & Atmt.FileName
          Atmt.SaveAsFile FileName 'saves each attachment'

          'this code opens each attachment'
          Set myShell = CreateObject("WScript.Shell")
          myShell.Run FileName

          'this sets the email as read'
          Item.UnRead = False
          'updates the counter'
          i = i + 1

        Next Atmt
      End If
    Next Item
  End If

  'Display results

  If i > 0 Then
    MsgBox "I found " & i & " attached files." _
     & vbCrLf & "They are saved on your desktop" _
     & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
  Else
    MsgBox "I didn't find any attached files in your mail.", vbInformation, _
     "Finished!"
 End If

'Replenish Memory'
GetAttachments_exit:

  Set Atmt = Nothing
  Set Item = Nothing
  Set ns = Nothing
  Exit Sub

  'function for sorting the excel attachment'

GetAttachments_err:
  MsgBox "An unexpected error has occurred." _
  & vbCrLf & "Please note and report the following information." _
  & vbCrLf & "Macro Name: GetAttachments" _
  & vbCrLf & "Error Number: " & Err.Number _
  & vbCrLf & "Error Description: " & Err.Description _
  , vbCritical, "Error!"
  Resume GetAttachments_exit
End Sub

Answer 1

欢迎使用 StackOverflow！

要回答您的具体问题，

我收到“尝试的操作失败。找不到对象。”错误在：
Set SubFolder = Mailbox.Folders("!Response File")

您收到此错误是因为“！响应文件”不在收件箱的父级中。按名称查找文件夹可能很棘手。 您可以改为通过 ID 访问该文件夹。 获取所需文件夹 ID 的一种方法是编写一个函数来执行此操作。

    Function GetInboxFolderID(FolderName As String) As String
    Dim nsp As Outlook.Folder
    Dim mpfSubFolder As Outlook.Folder
    Dim mpfSubFolder2 As Outlook.Folder
    Dim flds As Outlook.Folders
    Dim flds2 As Outlook.Folders

    Set nsp = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set flds = nsp.Folders
    Set mpfSubFolder = flds.GetFirst
    Do While Not mpfSubFolder Is Nothing
        If mpfSubFolder.Name = FolderName Then
            GetInboxFolderID = mpfSubFolder.EntryID
            Exit Function
        End If
        Set flds2 = mpfSubFolder.Folders
        Set mpfSubFolder2 = flds2.GetFirst
        Do While Not mpfSubFolder2 Is Nothing
            If mpfSubFolder2.Name = FolderName Then
                GetInboxFolderID = mpfSubFolder2.EntryID
                Exit Function
            End If
            Set mpfSubFolder2 = flds2.GetNext
        Loop
        Set mpfSubFolder = flds.GetNext
    Loop
End Function

另外，这里有一个测试它的代码。

Sub testing()
Dim tv As String
tv = GetInboxFolderID("Response File")
  Set myNewFolder = Application.Session.GetFolderFromID(tv)
 myNewFolder.Display

End Sub 

此函数循环遍历您的主要用户文件夹集，然后检查每个文件夹中的文件夹名称中给出的字符串。如果函数找到它，则将 ID 返回到该文件夹​​。

测试子程序只是用于调试目的，当你运行它时，它应该打开你在函数中命名的文件夹，即“响应文件”

换行：

Set SubFolder = Mailbox.Folders("!Response File")

收件人：

Set SubFolder = Application.Session.GetFolderFromID(GetInboxFolderID("Response File"))

如果你实现了我的功能，应该可以解决你当前的错误。

此外，您可以使用 SendKeys 关闭“Okay”消息

Call AppActivate("Adobe Reader", True)
 DoEvents
 SendKeys "{Enter}"

希望这会有所帮助！