Outlook 365 archiviert nicht richtig

Sub ArchiveCurrentImapFolder()
    Dim fd As folder, strMailErrors As String, errorCounter As Integer, sizeCounter As Double, objMail As MailItem
    sizeCounter = CDbl(0)
    Set fd = ActiveExplorer.CurrentFolder
    If fd.DefaultItemType = olMailItem Then
        Dim backupFolder As folder, currentMail As MailItem, obj As MailItem
        Dim removedate As Date
        Dim itemscollection As items
        oldelements = InputBox("Elemente älter als X Monate archivieren:", "Archivierungszeitraum", "12")  
        If Not IsNumeric(oldelements) Or oldelements = False Then Exit Sub
        MsgBox "Im nächsten Schritt bitte den Backup-Zielordner auswählen in den die Mails verschoben werden.", vbInformation  
        Set backupFolder = Session.PickFolder
        If backupFolder Is Nothing Then Exit Sub
        removedate = DateTime.DateAdd("m", -oldelements, DateTime.Date)  
        
        Dim mailCollection As New Collection
        
        For Each objMail In fd.items
            On Error GoTo MailIsError
            If objMail.ReceivedTime < removedate Then
                If objMail.DownloadState = olHeaderOnly Then
                    objMail.MarkForDownload = olMarkedForDownload
                End If
                mailCollection.Add Item:=objMail
                sizeCounter = sizeCounter + objMail.Size
            End If
        Next
        Application.Session.SendAndReceive False
        For i = 1 To mailCollection.Count
            Set obj = mailCollection.Item(i)
            obj.Move backupFolder
        Next
        sizeCounter = Round((sizeCounter / 1048576), 2)
        MsgBox mailCollection.Count & " Nachricht(en) wurden archiviert nach " & backupFolder.FolderPath & vbCrLf & "Die Größe aller archivierten Nachrichten betrug: " & sizeCounter & " MB" & vbCrLf & strMailErrors  
        
    End If
    Set mailCollection = Nothing
    Exit Sub
    
MailIsError:
    errorCounter = errorCounter + 1
    strMailErrors = strMailErrors & errorCounter & ". Nachricht mit dem Betreff: '" & currentMail.subject & "' hat folgenden Fehler verursacht und wurde nicht verschoben : " & Err.Description & vbCrLf  
    Resume Next
End Sub