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

Public Type PdfAppInfo: FullPath As String: ExeName As String: End Type
Public Function GetPdfDefaultExe() As PdfAppInfo
    'patricktoulon
    Dim WsH As Object, progId$, cmd$
    Dim info As PdfAppInfo, str$
    Set WsH = CreateObject("WScript.Shell")
    progId = WsH.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts\.pdf\UserChoice\ProgId")
    cmd = WsH.RegRead("HKCR\" & progId & "\shell\open\command\")
    If InStr(cmd, """") > 0 Then
        str = Split(Mid(cmd, 2), """")(0)
    Else
        str = cmd
    End If
    If cmd = "" Then MsgBox "l 'application n'a pas pu determiner l'application par défaut pour les pdfs":
    info.FullPath = str
    info.ExeName = str
    GetPdfDefaultExe = info
End Function

'//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Sub ExtrairePDFDepuisBinEtNettoyer()
    Dim col As New Collection
    Dim WsH As Object, dossierEmbeddings As Object, items As Object, item As Object, stream As Object
    Dim tempo$, chemin$, binPath$, pdfPath$, bytes() As Byte, pdfBytes() As Byte, i&, startPos&, endPos&
    Dim appdefaut As PdfAppInfo
    tempo = ThisWorkbook.Path & "\tempo.zip" 'chemin du zip
    ThisWorkbook.SaveCopyAs tempo 'on sauve une copie temporaire du classeur au format zip directement
    Application.Wait Now + TimeValue("0:00:01")
    col.Add tempo ' le premier item ce sera le zip complet
    
    Set WsH = CreateObject("Shell.Application") 'c'rée l'object shel application
    Set dossierEmbeddings = WsH.Namespace(tempo & "\xl\embeddings") 'le path complet du dossier dans le zip du dossier embbedding
    If dossierEmbeddings Is Nothing Then MsgBox "Pas de dossier xl\embeddings": Exit Sub 'on se casse si y a pas
    
    Set items = dossierEmbeddings.items 'collection des items a l'inteieurs du dossier
    For Each item In items
        If Dir(ThisWorkbook.Path & "\" & item.Name) <> "" Then Kill ThisWorkbook.Path & "\" & item.Name
        WsH.Namespace(ThisWorkbook.Path).CopyHere item, 4 'on extrait
        col.Add ThisWorkbook.Path & "\" & item.Name 'on ajoute les path a la collection
    Next item
    DoEvents
    Set WsH = Nothing
    
    ' Étape 2 : Extraction PDF
    For i = 2 To col.Count
        binPath = col(i)
        pdfPath = Replace(binPath, ".bin", ".pdf")
        col.Add pdfPath
        If Dir(pdfPath) <> "" Then Kill pdfPath
        Set stream = CreateObject("ADODB.Stream")
        stream.Type = 1
        stream.Open
        stream.LoadFromFile binPath
        bytes = stream.Read
        stream.Close
        
        ' Chercher %PDF le debut
        startPos = -1
        For j = 0 To UBound(bytes) - 3
            If Chr(bytes(j)) = "%" And Chr(bytes(j + 1)) = "P" And Chr(bytes(j + 2)) = "D" And Chr(bytes(j + 3)) = "F" Then
                startPos = j
                Exit For
            End If
        Next j
        
        ' Chercher %%EOF la fin
        endPos = -1
        For j = UBound(bytes) - 5 To startPos + 4 Step -1
            If Chr(bytes(j)) = "%" And Chr(bytes(j + 1)) = "%" And Chr(bytes(j + 2)) = "E" And Chr(bytes(j + 3)) = "O" And Chr(bytes(j + 4)) = "F" Then
                endPos = j + 4
                Exit For
            End If
        Next j
        
        ' Extraire et écrire le PDF
        If startPos >= 0 And endPos > startPos Then
            ReDim pdfBytes(endPos - startPos) As Byte
            For j = startPos To endPos
                pdfBytes(j - startPos) = bytes(j)
            Next j
            
            Set stream = CreateObject("ADODB.Stream")
            stream.Type = 1
            stream.Open
            stream.Write pdfBytes
            stream.SaveToFile pdfPath, 2
            stream.Close
        Else
            MsgBox "PDF non trouvé dans " & binPath
        End If
    Next i
    
    'ouvrir les pdfs
    appdefaut = GetPdfDefaultExe
    MsgBox appdefaut.ExeName
    For i = 2 To col.Count
       If Right(col(i), 4) = ".pdf" Then Shell """" & appdefaut.ExeName & """ """ & """" & col(i) & """"
    Next
    
    ' Étape 3 : Nettoyage des fichiers bin
    For i = 1 To col.Count
         If Right(col(i), 4) <> ".pdf" Then Kill col(i)
    Next i
    
    MsgBox "Extraction terminée et fichiers bin supprimés."
End Sub

        'Rename le .bin en .txt
        Name binPath As txtPath
        
        'Lecture du fichier .txt du répertoire TEMP
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        Set oTextFile = oFSO.OpenTextFile(txtPath, ForReading)
        Text = oTextFile.readall
        oTextFile.Close

        'Start of PDF
        startPos = InStr(Text, "%PDF")
        
        'End of PDF
        endPos = InStrRev(Text, "%%EOF")
        endPos = endPos + 4
MsgBox "Len(Text) = " & Len(Text) & ", startPos = " & startPos & ", endPos = " & endPos

Sub ExtrairePDFDepuisBinaire()
    Dim sourcePath As String
    Dim destPath As String
    Dim fileNum As Integer
    Dim bytes() As Byte
    Dim i As Long
    Dim startPos As Long
    Dim fileSize As Long
   
    ' ?? Chemin du fichier source
    sourcePath = "C:\temp\oleObject2.bin"
    ' ?? Chemin du fichier PDF de sortie
    destPath = "C:\temp\fichier_extrait.pdf"
   
    ' ?? Ouvrir le fichier source en binaire
    fileNum = FreeFile
    Open sourcePath For Binary Access Read As #fileNum
    fileSize = LOF(fileNum)
    If fileSize = 0 Then
        MsgBox "Fichier vide : " & sourcePath, vbExclamation
        Close #fileNum
        Exit Sub
    End If
   
    ReDim bytes(1 To fileSize)
    Get #fileNum, , bytes
    Close #fileNum
   
    ' ?? Chercher la séquence %PDF (ASCII 37, 80, 68, 70)
    For i = 1 To fileSize - 3
        If bytes(i) = 37 And bytes(i + 1) = 80 And bytes(i + 2) = 68 And bytes(i + 3) = 70 Then
            startPos = i
            Exit For
        End If
    Next i
   
    If startPos = 0 Then
        MsgBox "Signature %PDF non trouvée dans " & sourcePath, vbExclamation
        Exit Sub
    End If
   
    ' ?? Extraire tout à partir de %PDF jusqu'à la fin
    Dim outBytes() As Byte
    ReDim outBytes(1 To fileSize - startPos + 1)
   
    Dim j As Long
    For j = 1 To UBound(outBytes)
        outBytes(j) = bytes(startPos + j - 1)
    Next j
   
    ' ?? Écrire dans le nouveau fichier PDF
    fileNum = FreeFile
    Open destPath For Binary Access Write As #fileNum
    Put #fileNum, , outBytes
    Close #fileNum
   
    MsgBox "Extraction terminée !" & vbCrLf & _
           "PDF enregistré sous : " & destPath, vbInformation
End Sub

Sub lecture1()    ' recupe le texte complet  avec binary acces read
    Dim laChaine As String, x, fichier As String
    fichier = "C:\Users\polux\Desktop\ttt.txt"'adapter ici le chemin 
    x = FreeFile
    Open fichier For Binary Access Read As #x
    laChaine = String(LOF(x), " ")
    Get #x, , laChaine
    Close #x
    MsgBox laChaine'lachaine contient tout le texte utilisable
End Sub