Скачать вложение Outlook на основе диапазона ячеек

Question

Я скомпилировал этот код для загрузки вложений из выбранных писем, если имена файлов вложений совпадают с каждой ячейкой в ​​столбце "D: D".

Код работает, когда в каждом выбранном письме есть только одно вложение и когда имя файла вложения точно соответствует значению ячейки.

Я пытался изменить его, чтобы оно работало независимо от того, сколько вложений определенное mail in selection имеет и что он загружает вложение, если его имя содержит значение в ячейке и не обязательно соответствует 100%. Но почему-то не работает код "0 PDF было загружено ...". (Нет сообщений об ошибках)

Любой совет более чем приветствуется!

Private Sub CommandButton1_Click()

Dim ol As Outlook.Application
Dim mi As Outlook.MailItem
Dim at As Outlook.Attachments
Dim os As Outlook.Selection
Dim I As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim strFilePath As String
Dim counter As Long
Dim Count As Long
Dim var As Boolean
Dim Celda As Range

' Get the path to your My Documents folder
strFolderpath = ThisWorkbook.Path & "\PDFs\"
On Error Resume Next

'Check if folder contain files already
FileName = Dir(strFolderpath)

    Do While FileName <> ""
        Count = Count + 1
        FileName = Dir()
    Loop

    If Count > 0 Then
        iRet = MsgBox("There are " & Count & " old pdfs in the folder." & vbCrLf & "Would you like to delete them?", vbYesNo, "Extract PDF")

        If iRet = vbNo Then
        Else
            If Count > 0 Then
                Kill strFolderpath & "*.pdf"
            End If
        End If
    Else

    End If


' Instantiate an Outlook Application object.
Set ol = CreateObject("Outlook.Application")

' Get the collection of selected objects.
Set os = ol.ActiveExplorer.Selection


For Each mi In os


    Set at = mi.Attachments
    lngCount = at.Count
    strDeletedFiles = ""

    If lngCount > 0 Then


        For I = lngCount To 1 Step -1


            strFile = at.Item(I).FileName

            strFilePath = strFolderpath & strFile

           'Ordena de burbuja, lento cunado hay muchas filas o muchos PDF
           'Puede mejorarse haciendo un table o hash table con los archivos detectados


            ' Save the attachment as a file.
            If InStr(UCase(strFilePath), ".PDF") > 0 Then


               For Each Celda In Sheets("Sheet1").Range("D:D")

                If Not IsEmpty(Celda) Then
                 If strFile = Celda & ".pdf" Then
                 at.Item(I).SaveAsFile strFilePath
                 counter = counter + 1
                 Celda.Interior.ColorIndex = 6
                  End If
                  End If
                 Next Celda

             End If


        Next I


        mi.Save
    End If
Next mi


MsgBox "Saved " & counter & " PDFs in the specific folder.", vbDefaultButton1, "Extract PDF"

ExitSub:

Set at = Nothing
Set mi = Nothing
Set os = Nothing
Set ol = Nothing
End Sub

https://answers.microsoft.com/en-us/msoffice/forum/msoffice_other-msoffice_custom-mso_365hp/use-macro-to-export-excel-attachment-document-from/774388f6-3008-4d85-99f9-d45f19b9d1c8

https://answers.microsoft.com/en-us/msoffice/forum/all/download-outlook-selective-attachments/9c9cad59-3b0c-4927-b728-bb18f0373047