Outlook vba将附件保存到特定文件夹在旧邮件上不起作用

Question

我有从https://www.slipstick.com/developer/save-attachments-to-the-hard-drive/下载的代码

我已根据需要进行了修改，将附件保存到带有主题和发件人邮件ID的特定文件夹中。

此宏可用于选择电子邮件并保存附件。此宏适用于今天，昨天甚至昨天所有选定的电子邮件的前一天。但是，当我选择较旧的日期电子邮件时，它不会保存所有选定的电子邮件，并且会跳至代码末尾而不保存所有选定的电子邮件。一些附件已保存，另一些未保存。但是并非所有附件都保存了。代码是这里。

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