Vba 循环浏览outlook未读电子邮件不工作

我很难让这个循环正常工作。有什么建议吗

   Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
                                 ExtString As String, DestFolder As String)
    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 MyDocPath As String
    Dim i As Integer
    Dim wsh As Object
    Dim fs As Object
    Dim InboxMsg As Object


    On Error GoTo ThisMacro_err

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)



    'To fix my issue I may have to change the loop to repeat the same number of 
    times as attachments

    ' Check subfolder for messages and exit of none found
    '    strFilter = "[Unread] = True"
    '    Set inboxItems = 

  ns.GetDefaultFolder(olFolderInbox).Folders(OutlookFolderInInbox).Items.Restrict(strFilter)


        If SubFolder.UnReadItemCount = 0 Then
        MsgBox "There are no New messages in this folder : " & 
    OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If

    'Create DestFolder if DestFolder = ""
    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.Item("mydocuments")
        DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.FolderExists(DestFolder) Then
            fs.CreateFolder DestFolder
        End If
    End If

    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If

    ' Check each message for attachments and extensions
    strFilter = "[Unread] = True"
    Set inboxItems = 

  ns.GetDefaultFolder(olFolderInbox).Folders(OutlookFolderInInbox).Items.Restrict(strFilter)

 '   For Each Item In inboxItems
    For i = inboxItems.Count To 1 Step -1 'Iterates from the end backwards
        Set InboxMsg = Inbox.Items(i)
  'For Each Item In inboxItems
   '      For Each Atmt In inboxItems(I).Attachments
       For Each Atmt In InboxMsg.Attachments

            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) 
    Then
                FileName = DestFolder & Format(Item.ReceivedTime, "yyyy-mmm-dd") & Atmt.FileName
                Atmt.SaveAsFile FileName

            End If
         Item.UnRead = "False"
    '        inboxItems(I).UnRead = "False"
        Next Atmt
    '         Item.UnRead = "false"

    Next


    ' Show this message when Finished
    If i = 0 Then
        MsgBox "You can find the files here : " _
             & DestFolder, vbInformation, "Finished!"
    Else
        MsgBox "No attached files in your mail.", vbInformation, "Finished!"
    End If

    ' Clear memory
    ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Exit Sub

    ' Error information
    ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit

    End Sub

将EmailAttachmentsToFolder（OutlookFolderInBox作为字符串保存_
ExtString作为字符串，DestFolder作为字符串）
Dim ns作为名称空间
将收件箱设置为MAPI文件夹
将子文件夹变暗为MAPIFolder
将项目变暗为对象
作为附件的Dim Atmt
将文件名设置为字符串
将MyDocPath设置为字符串
作为整数的Dim i
将wsh设置为对象
作为对象的Dim fs
Dim InboxMsg作为对象
错误时转到此宏\u错误
设置ns=GetNamespace（“MAPI”）
设置收件箱=ns.GetDefaultFolder（olFolderInbox）
设置子文件夹=收件箱。文件夹（OutlookFolderInBox）
'要解决我的问题，我可能必须更改循环以重复相同数量的循环
作为附件的时间
'检查子文件夹中是否有消息，并退出“未找到”
'strFilter=“[Unread]=True”
'设置收件箱=
ns.GetDefaultFolder（olFolderInbox）.Folders（OutlookFolderInBox.Items.Restrict（strFilter）
如果SubFolder.unreademcount=0，则
MsgBox“此文件夹中没有新邮件：&”
了望台_
VBA信息，“未找到任何内容”
设置子文件夹=无
设置收件箱=无
设置ns=无
出口接头
如果结束
'如果DestFolder=“”则创建DestFolder“”
如果DestFolder=“”，则
设置wsh=CreateObject（“WScript.Shell”）
设置fs=CreateObject（“Scripting.FileSystemObject”）
MyDocPath=wsh.SpecialFolders.Item（“mydocuments”）
DestFolder=MyDocPath&“\”格式（现在为“dd-mmm-yyy-hh-mm-ss”）
如果不是fs.FolderExists（DestFolder），则
fs.CreateFolder DestFolder
如果结束
如果结束
如果正确（DestFolder，1）“\”则
DestFolder=DestFolder&“\”
如果结束
'检查每封邮件的附件和扩展名
strFilter=“[Unread]=True”
设置收件箱=
ns.GetDefaultFolder（olFolderInbox）.Folders（OutlookFolderInBox.Items.Restrict（strFilter）
'对于inboxItems中的每个项目
对于i=inboxItems.Count到1，步骤-1'从结尾向后迭代
设置InboxMsg=Inbox.Items（i）
'对于inboxItems中的每个项目
“对于inboxItems（I）中的每个Atmt。附件
对于InboxMsg.附件中的每个Atmt
如果LCase（右（Atmt.FileName，Len（ExtString））=LCase（ExtString）
然后
FileName=DestFolder&Format（Item.ReceivedTime，“yyyy-mmm-dd”）&Atmt.FileName
Atmt.SaveAsFile文件名
如果结束
Item.UnRead=“False”
'inboxItems（I）.UnRead=“False”
下一个Atmt
'Item.UnRead=“false”
下一个
'完成后显示此消息
如果i=0，那么
MsgBox“您可以在此处找到文件：”_
&DestFolder，vbInformation，“完成！”
其他的
MsgBox“邮件中没有附加文件”，vbInformation，“已完成！”
如果结束
“清除内存
此宏_退出：
设置子文件夹=无
设置收件箱=无
设置ns=无
设置fs=Nothing
设置wsh=Nothing
出口接头
'错误信息
此宏错误：
MsgBox“发生意外错误。”_
&vbCrLf&“请注意并报告以下信息。”_
&vbCrLf&“宏名称：SaveEmailAttachmentsToFolder”_
&vbCrLf&“错误编号：”&错误编号_
&vbCrLf&“错误描述：”&错误描述_
，vbCritical，“错误！”
继续此宏。\u退出
端接头

下面是一个快速示例，为未读和带有附件的项目设置过滤器

---

它不应该是

Item.Unread=False

（没有引号）。“有麻烦”实际上是什么样子的？显示

Restrict

的用法-下面是描述“将筛选器应用于Items集合，返回一个新集合，其中包含原始集合中与筛选器匹配的所有项目”。您将忽略代码中返回的集合。查看您的配置文件，你的回答从来没有被接受过。我不知道我必须接受它。我一直在尝试很多不同的事情。我有一些这样的代码，但它会跳过未读的项目。我试着让它从底部开始，一直工作到文件夹的顶部

Option Explicit
Public Sub Example()
    Dim olNs As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim i As Long
    Dim Filter As String

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

    Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:hasattachment" & _
                       Chr(34) & "=1 AND " & _
                       Chr(34) & "urn:schemas:httpmail:read" & _
                       Chr(34) & "=0"

    Set Items = Inbox.Items.Restrict(Filter)

    For i = Items.Count To 1 Step -1
        Debug.Print Items(i) 'Immediate Window
    Next
End Sub