outlook vba для сохранения вложения в определенную папку не работает на старых письмах

Question

У меня есть код, который я скачал с https://www.slipstick.com/developer/save-attachments-to-the-hard-drive/

Я внес изменения в соответствии с моей необходимостью сохранить вложение в определенную папку с темой и идентификатором отправителя.

Этот макрос работает на выделение писем и сохраняет вложения.Этот макрос отлично работает с сегодняшним, вчерашним или даже вчерашним днем ​​по всем выбранным письмам.Но когда я выбираю электронные письма с более ранними датами, он не сохраняет все выбранные электронные письма и пропускает до конца кода, не сохраняя все выбранные электронные письма.некоторые вложения сохранены, а некоторые нет.Но не все вложения сохраняются. Вот код.

Public Sub SaveAttachmentsInFolder()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim objSubject As String
Dim sendermail As String
Dim sdate As Date
Dim adate As String
Dim LastPosition As Integer
Dim objSubject1 As String
Dim AttachmentName As String
Dim AttachmentType As String
Dim strFilename As String



    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOL = Application

    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection

' The attachment folder needs to exist
' You can change this to another folder name of your choice

' Set the Attachment folder.

  strFolderpath = "E:\Reattach"

' Check each message for attachments
    For Each objMsg In objSelection

        objSubject = objMsg.Subject
        sendermail = objMsg.SenderEmailAddress
        sdate = objMsg.SentOn

        FirstDelPos = InStr(sendermail, "@")
        SecondDelPos = InStrRev(sendermail, ".")
        StringBwDels = Mid(sendermail, FirstDelPos + 1, SecondDelPos - FirstDelPos - 1)
        company = StrConv(StringBwDels, vbProperCase)
        company1 = Split(sendermail, "@")(0)




        'Set the Attachment folder.
        strFolder = strFolderpath & "\OLAttachments\"
        Set objAttachments = objMsg.Attachments
        'put it together with the sender name

            If company = "Gmail" Or company = "Yahoo" Or company = "Yahoo.co" Or company = "Vsnl" Or company = "Vsnl.in" Then
                strFolder1 = strFolder & company1
                strFolder = strFolder & company1 & "\" & objMsg.SenderName & "\"

            Else
                strFolder1 = strFolder & company
                strFolder = strFolder & company & "\" & objMsg.SenderName & "\"

        End If



        ' if the sender's folder doesn't exist, create it
            If Not FSO.FolderExists(strFolder1) Then
                 MkDir (strFolder1)
                'fso.CreateFolder (strFolder1)
            End If

        ' if the sender's folder doesn't exist, create it
            If Not FSO.FolderExists(strFolder) Then
                MkDir (strFolder)
                'fso.CreateFolder (strFolder)
             End If


        'MsgBox (sDate)
        adate = Format(sdate, "dd mm yyyy hhmm")


            Dim rLen As Integer
            Dim rChar As String
            Dim j As Integer
            Dim y As Variant




            rChar = ":"
            rLen = Len(objSubject)
            For j = rLen To 1 Step -1
                y = Mid(objSubject, j - 1, 1)
                    If Mid(objSubject, j - 1, 1) = rChar Then
                        LastPosition = j
                        Exit For
                    Else
                    End If
            Next j


            If (LastPosition = 1) Then
                LastPosition = LastPosition - 1
            End If
        objSubject = Right(objSubject, Len(objSubject) - Len(Left(objSubject, LastPosition)))

        objSubject1 = ReplaceIllegalChar(objSubject)

        Set objAttachments = objMsg.Attachments

        lngCount = objAttachments.Count
            If lngCount > 0 Then
                ' Use a count down loop for removing items
                ' from a collection. Otherwise, the loop counter gets
                ' confused and only every other item is removed.
                    For i = lngCount To 1 Step -1
                        AttachmentName = objAttachments.Item(i).FileName
                        AttachmentType = Mid$(LCase(objAttachments.Item(i).FileName), InStrRev(LCase(objAttachments.Item(i).FileName), Chr(46)) + 1)

                            If objAttachments.Item(i).Size > 10000 Then

                            Else:
                            GoTo 10
                            End If


                ' Get the file name.
                strFilename = AttachmentName & objSubject1 & "-" & adate & "-" & "SR" & i & "-" & sendermail & "." & AttachmentType

                ' Combine with the path to the Temp folder.
                strFile = strFolder & strFilename



                ' Save the attachment as a file.
                objAttachments.Item(i).SaveAsFile strFile


10:

                    Next i
            Else
            End If
Next

MsgBox ("Task Complete")
Exit Sub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
MsgBox ("Task Complete")
End Sub

Function ReplaceIllegalChar(strIn As String) As String

Dim j As Integer
Dim varStr As String, xStr As String
varStr = strIn
For j = 1 To Len(varStr)
   Select Case Asc(Mid(varStr, j, 1))
        Case 48 To 57, 65 To 90, 97 To 122
        xStr = xStr & Mid(varStr, j, 1)
   Case Else
        xStr = xStr & "_"

   End Select
Next
ReplaceIllegalChar = xStr
End Function