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
    Dim ErrNumber As Long
   
    'Shell Object
    Set oShell = CreateObject("Shell.Application")
   
    'Nom complet du fichier PDF à afficher
    pdfPath = Environ("TEMP") & "\" & pdfFileName
   
    On Error Resume Next
    Kill pdfPath
    ErrNumber = Err.Number
    On Error GoTo 0
   
    Select Case ErrNumber
        'Pas d'erreur
        Case 0
            'OK
           
        'Fichier introuvable
        Case 53
            'OK
           
        'Permission refusée (File in use)
        Case 70
            GoTo OpenPDFFile
       
        'Autre erreur ?
        Case Else
            MsgBox "Erreur #" & Err.Number & " " & Err.Description
            Stop
    End Select
   
    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"
   
    'Kill existing zipPath
    If Not Len(Dir(zipPath)) = 0 Then Kill zipPath

    'Save the Workbook as ZIP zipPath file
    ActiveWorkbook.SaveAs zipPath
    ActiveWorkbook.Close savechanges:=False
   
    'localisation des fichiers .bin du .zip
    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
       
        If Not Len(Dir(binPath)) = 0 Then Kill binPath

        'Copy le .bin du ZIP dans le répertoire TEMP
        oShell.Namespace(Environ("TEMP")).CopyHere binItem, 4
       
        'Lecture du fichier .bin 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
    If Not Len(Dir(zipPath)) = 0 Then Kill zipPath
   
OpenPDFFile:
    '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

Sub testrecursivelistcmb()
    Dim items As Collection
    With ActiveSheet
        
        For Each ole In .OLEObjects
            ole.Select
            c = c + 1
            lig = 0
            DoEvents
            
            Set items = cmbarlistitems(Application.CommandBars("OLE Object"))
            
            Dim i As Variant
            With Sheets(2)
                For Each i In items
                    lig = lig + 1
                    .Cells(lig, c) = i
                    Debug.Print i
                Next i
            End With
        Next
    End With
End Sub

Function cmbarlistitems(parent As Object, Optional start As Boolean = True) As Collection
    Static tbl As Collection
    If start Then Set tbl = New Collection
    
    Dim ctrl As CommandBarControl
    For Each ctrl In parent.Controls
        Select Case ctrl.Type
            Case msoControlButton
                tbl.Add ctrl.Caption
            Case msoControlPopup
                tbl.Add ctrl.Caption
                ' Appel récursif sur le contrôle popup lui-même
                cmbarlistitems ctrl, False
        End Select
    Next ctrl
    
    Set cmbarlistitems = tbl
End Function

'-------------------------------------------------------------------------
'Détermine si un Embbeded PDF a été intégré avec Acrobat présent sur le PC
'-------------------------------------------------------------------------
Function IsAcrobatEmbbededPDF(EmbbededPDF As OLEObject) As Boolean
    Dim ActiveWorksheet As Worksheet
    Dim ActiveCellule As Range
    Dim CommandBarControl As CommandBarControl
    '
    Const NonAcrobatCommandBarControl = "*Objet d’environnement du Gestionnaire de liaisons"
    
    Application.ScreenUpdating = False
    Set ActiveWorksheet = ActiveSheet
    EmbbededPDF.Parent.Activate
    DoEvents
    Set ActiveCellule = ActiveCell
    
    EmbbededPDF.Select
    
    With CommandBars("OLE Object")
        For Each CommandBarControl In .Controls
            If CommandBarControl.Visible Then
                If CommandBarControl.Caption Like NonAcrobatCommandBarControl Then Exit For
            End If
        Next CommandBarControl
    End With
    
    ActiveCellule.Select
    
    ActiveWorksheet.Activate
    ActiveCell.Select
    DoEvents
    
    'Return value
    If CommandBarControl Is Nothing Then
        IsAcrobatEmbbededPDF = True
    End If
End Function