收件箱的参考子文件夹用于移动邮件

Question

我使用的是Outlook2010。我收到的主题行相同的电子邮件会打开PDF。 打开PDF时，Adobe询问我是否要将其添加到Excel响应文件中，然后说“是”。

当Adobe询问要添加到响应文件中时，我希望它以“确定”进行响应，但是我可以不用它来进行管理。 在这一行：

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

我收到一个错误：

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

未读电子邮件所在的子文件夹在我的收件箱下面称为“！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")

您收到此错误，因为“！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关闭“确定”消息

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

希望这可以帮助！