Excel Macro以保存Outlook 2010附件，将最早的电子邮件保存为最新的电子邮件

Question

Need to save excel attachments in Outlook emails from oldest email to newest email and mark email as read. The newer attachments will overwrite the older if there is more than one unread email.

I receive an number of emails daily that need to be saved to run a report. However, if one report is missed, it is ignored and I go to the next dataset. The following works but does not always save the oldest first...it jumps around.

I have tried a number of options to save oldest first, with no luck. Any help on how I could make this consistently take the oldest email first. Thanks

Sub Save_Attachments()
    Dim olApp As Outlook.Application, olNameSpace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
    Dim olAttachment As Outlook.Attachment, lngAttachmentCounter As Long
    Dim i As String
On Error GoTo Oooops
    Set olApp = New Outlook.Application
    Set olNameSpace = olApp.GetNamespace("MAPI")
    Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders("sub_folder")
    If olFolder Is Nothing Then Exit Sub
    For Each olMail In olFolder.Items
        If olMail.UnRead = True Then
             For Each olAttachment In olMail.Attachments
                lngAttachmentCounter = lngAttachmentCounter + 1
                olAttachment.SaveAsFile ThisWorkbook.Path & "\zzzzz.xls"
            Next olAttachment
        End If
        If olMail.UnRead Then
            olMail.UnRead = False
        End If
    Next olMail
    Exit Sub
Oooops:
    MsgBox Err.Description, vbExclamation, "An error occurred"
End Sub

Answer 1

Since you did not state the options you tried maybe you did not try

For j = olFolder.Items.count To 1 Step -1 

Something like this.

Option Explicit

 Sub Save_Attachments_ReverseOrder()

    Dim olApp As Outlook.Application, olNameSpace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olMail As Object ' <-- olMail is not necessarily a mailitem
    Dim olAttachment As Outlook.attachment, lngAttachmentCounter As Long
    Dim j As Long

    On Error GoTo Oooops

    Set olApp = New Outlook.Application
    Set olNameSpace = olApp.GetNamespace("MAPI")
    Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders("sub_folder")

    If olFolder Is Nothing Then Exit Sub

    For j = olFolder.Items.count To 1 Step -1    

        Set olMail = olFolder.Items(j)
        If TypeOf olMail Is mailitem Then
            If olMail.UnRead = True Then

                Debug.Print olMail.subject & " - " & olMail.ReceivedTime

                 'For Each olAttachment In olMail.Attachments
                 '   lngAttachmentCounter = lngAttachmentCounter + 1
                 '   olAttachment.SaveAsFile ThisWorkbook.Path & "\zzzzz.xls"
                 'Next olAttachment

                 olMail.UnRead = False             

            Else

                Debug.Print vbCr & olMail.subject & " - " & olMail.ReceivedTime & " was previously read"

            End If     

        Else

            Debug.Print vbCr & "Current item is not a mailitem."      

        End If      

    Next j

    Exit Sub

Oooops:

    MsgBox Err.Description, vbExclamation, "An error occurred"

End Sub