XL 2021 VBA - Enregistrer en fichier un Embbeded PDF créé en présence d'Adobe Acrobat sur le PC

'-------------------------------------------------------------------
'Extrait le PDF Acrobat en passant par un ZIP du Workbook et les BIN
'-------------------------------------------------------------------
Private Sub AcrobatPDFShow(Shape As Shape, pdfFileName As String)
    Dim oShell As Object
    Dim embbededFilesFolder As Object
    Dim binItems As Object
    Dim binItem As Object
    Dim zipPath As String
    Dim binPath As String
    Dim pdfPath As String
    Dim fileNum As Integer
    Dim fileSize As Long
    Dim Text As String
    Dim startPos As Long
    Dim endPos As Long

    Application.ScreenUpdating = False
   
    'Ajout d'un nouveau classeur
    Application.Workbooks.Add
    Shape.Copy
    ActiveSheet.Paste
   
    'ZIP file full name en répertoire TEMP
    zipPath = Environ("TEMP") & "\" & ActiveWorkbook.Name & ".zip"
   
    If Not Len(Dir(zipPath)) = 0 Then
        Kill zipPath
    End If

    'Save the Workbook as ZIP file
    ActiveWorkbook.SaveAs zipPath
    ActiveWorkbook.Close savechanges:=False
   
    Set oShell = CreateObject("Shell.Application")
    Set embbededFilesFolder = oShell.Namespace(zipPath & "\xl\embeddings")
   
    'Set binItem = embbededFilesFolder.items(1) -> Erreur !
    Set binItems = embbededFilesFolder.items
   
    'Il n'y en a qu'un seul mais obligé de faire cette boucle
    For Each binItem In binItems
        binPath = Environ("TEMP") & "\" & binItem.Name
        pdfPath = Environ("TEMP") & "\" & pdfFileName
       
        On Error Resume Next
        Kill binPath
        Kill pdfPath
        On Error GoTo 0
       
        'Copy le .bin du ZIP dans le répertoire TEMP
        oShell.Namespace(Environ("TEMP")).CopyHere binItem, 4
       
        'Lecture du fichier .txt du répertoire TEMP
        fileNum = FreeFile
        Open binPath For Binary Access Read As #fileNum
        fileSize = LOF(fileNum)
        Text = String(fileSize + 1, Chr(0))
        Get #fileNum, , Text
        Close #fileNum

        'Start of PDF
        startPos = InStr(Text, "%PDF")
       
        'End of PDF
        endPos = InStrRev(Text, "%%EOF")
        endPos = endPos + 4
       
        'Extraction et écriture du fichier PDF
        If startPos >= 0 And endPos > startPos Then
            Text = Mid(Text, startPos, endPos - startPos + 1)
            fileNum = FreeFile
            Open pdfPath For Binary Access Write As #fileNum
            Put #fileNum, , Text
            Close #fileNum
        End If
    Next binItem
   
    'Suppression du ZIP
    Kill zipPath
   
    'Affichage du fichier
    oShell.Open (pdfPath)
End Sub

'Set binItem = embbededFilesFolder.items(1) -> Erreur !
    Set binItems = embbededFilesFolder.items

Set binItem = embbededFilesFolder.items.item("pierrepauljacques.bin") ->GOOD !
Set binItems = embbededFilesFolder.items' ca c'est la collections tout court

Set oShell = CreateObject("Shell.Application")
    For Each Item In oShell.Namespace(zipPath & "\xl\embeddings").items
       MsgBox Item.Name & vbCrLf & Item.Path
      'blablablabla'
    Next Item

Sub testx3()
    Dim zip$
    zip = ThisWorkbook.Path & "\tempo.zip"
    If Dir(zip) <> "" Then Kill zip
    ThisWorkbook.SaveCopyAs zip
    DoEvents
    ListerPropertiesZip zip
End Sub



Sub ListerPropertiesZip(zipPath As String)
   'patricktoulon archive creatorRibbonx 4.9.9
   Dim oShell As Object, oFolder As Object, oItem As Object
    Dim message As String
    
    Set oShell = CreateObject("Shell.Application")
    
    Set oFolder = oShell.Namespace(zipPath & "\xl\embeddings") '"\customUI\images"
    If oFolder Is Nothing Then MsgBox "Chemin introuvable": Exit Sub
    
    
    ' Boucle sur tous les items
    For Each oItem In oFolder.items
        message = "---- Item ----" & vbCrLf
        On Error Resume Next
        
        ' Propriétés classiques
        message = message & "Name: " & oItem.Name & vbCrLf
        message = message & "Path: " & oItem.Path & vbCrLf
        message = message & "Type: " & oItem.Type & vbCrLf
        message = message & "Size: " & oItem.Size & vbCrLf
        message = message & "IsFolder: " & oItem.IsFolder & vbCrLf
        message = message & "Attributes: " & oItem.Attributes & vbCrLf
        message = message & "CreationDate: " & oItem.CreationDate & vbCrLf
        message = message & "ModifyDate: " & oItem.ModifyDate & vbCrLf
        
          message = message & "Self.Name: " & oItem.Self.Name & vbCrLf ' Self represente l'object donc .Name kiff kiff)
        
        
        message = message & "Parent.Title: " & oItem.Parent.Title & vbCrLf ' attention le .parent est fragile pas toujours fonctionnel dans un ZIP)
        
        'Action avec  Verbs disponibles
        Dim v As Object
        message = message & vbCrLf & "Action possible avec Verbs: " & vbCrLf
        For Each v In oItem.Verbs
            message = message & v.Name & "; "
        Next v
        message = message & vbCrLf
        
        ' propriété etendues
        message = message & vbCrLf & "propriété etendue possiblement récupérables: " & vbCrLf
       Dim i As Integer
        For i = 0 To 100 ' on teste les index possibles de getdetail
            Dim val As Variant
            val = oFolder.GetDetailsOf(oItem, i)
            If val <> "" Then
                message = message & "Detail[" & i & "]: " & val & vbCrLf
            End If
        Next i
        
        On Error GoTo 0
        MsgBox message
    Next oItem
    Kill zipPath
End Sub

Set binItem = embbededFilesFolder.items.item("oleObject1.bin")

Sub test2()
    Dim ole As OLEObject
    For Each ole In ActiveSheet.OLEObjects
        MsgBox ole.Name & " : " & IsAdobeReader(ole)
        DoEvents
    Next
End Sub

Function IsAdobeReader(ole As OLEObject) As Boolean
    Dim ctrl As CommandBarControl
    ole.Select
    With CommandBars("OLE Object")
          For Each ctrl In .Controls
            If ctrl.Caption Like "*Acrobat Document" Then
                IsAdobeReader = True
                Exit For
            End If
        Next
    End With
End Function