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

Option Explicit

Sub ExtractPDFsFromXLSX()
    Dim xlsxPath As String
    Dim tempDir As String
    Dim outputDir As String
    Dim fso As Object
    Dim sh As Object
    Dim binFile As Object
    Dim pdfBytes() As Byte
    Dim startPos As Long
    
    ' === Sélection du fichier .xlsx ===
    xlsxPath = Application.GetOpenFilename("Fichiers Excel (*.xlsm),*.xlsm")
    If xlsxPath = "False" Then Exit Sub
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set sh = CreateObject("WScript.Shell")
    
    ' Dossiers temporaires et sortie
    tempDir = Environ("TEMP") & "\xlsx_extract"
    outputDir = fso.BuildPath(fso.GetParentFolderName(xlsxPath), "PDF_extraits")
    
    If fso.FolderExists(tempDir) Then fso.DeleteFolder tempDir, True
    fso.CreateFolder tempDir
    
    If Not fso.FolderExists(outputDir) Then fso.CreateFolder outputDir
    
    ' === Extraire le .xlsx (ZIP) avec tar ===
    ' Windows 10+ inclut tar.exe
    sh.Run "cmd /c tar -xf """ & xlsxPath & """ -C """ & tempDir & """", 0, True
    
    ' === Parcourir tous les .bin dans xl/embeddings ===
    Dim embDir As String
    embDir = tempDir & "\xl\embeddings"
    If Not fso.FolderExists(embDir) Then
        MsgBox "Aucun dossier xl\embeddings trouvé", vbExclamation
        Exit Sub
    End If
    
    Dim fileName As String
    Dim pdfCount As Long
    pdfCount = 0
    
    For Each binFile In fso.GetFolder(embDir).Files
        If LCase(fso.GetExtensionName(binFile.Name)) = "bin" Then
            ' Lire le binaire
            pdfBytes = ReadBinaryFile(binFile.path)
            
            ' Chercher la position de %PDF
            startPos = InBinary(pdfBytes, StrConv("%PDF", vbFromUnicode))
            If startPos > 0 Then
                ' Extraire tout depuis %PDF
                pdfBytes = SliceBinary(pdfBytes, startPos, UBound(pdfBytes) + 1)
                
                ' Écrire le PDF
                fileName = fso.BuildPath(outputDir, Replace(binFile.Name, ".bin", ".pdf"))
                WriteBinaryFile fileName, pdfBytes
                pdfCount = pdfCount + 1
            End If
        End If
    Next binFile
    
    MsgBox pdfCount & " PDF extrait(s) dans : " & outputDir, vbInformation
    
    ' Nettoyage
    fso.DeleteFolder tempDir, True
End Sub

' === Fonctions utilitaires ===

Function ReadBinaryFile(path As String) As Byte()
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 1 ' adTypeBinary
    stream.Open
    stream.LoadFromFile path
    ReadBinaryFile = stream.Read
    stream.Close
End Function

Sub WriteBinaryFile(path As String, data() As Byte)
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 1
    stream.Open
    stream.Write data
    stream.SaveToFile path, 2 ' adSaveCreateOverWrite
    stream.Close
End Sub

Function InBinary(data() As Byte, pattern As String) As Long
    Dim i As Long, plen As Long, dlen As Long
    Dim match As Boolean
    Dim j As Long
    plen = LenB(pattern)
    If UBound(data) < 0 Then InBinary = 0: Exit Function
    dlen = UBound(data) + 1
    For i = 0 To dlen - plen
        match = True
        For j = 1 To plen
            If data(i + j - 1) <> AscB(MidB(pattern, j, 1)) Then
                match = False: Exit For
            End If
        Next j
        If match Then
            InBinary = i
            Exit Function
        End If
    Next i
    InBinary = 0
End Function

Function SliceBinary(data() As Byte, startPos As Long, endPos As Long) As Byte()
    Dim out() As Byte
    Dim size As Long, i As Long
    If endPos <= startPos Then ReDim out(-1): SliceBinary = out: Exit Function
    size = endPos - startPos
    ReDim out(size - 1)
    For i = 0 To size - 1
        out(i) = data(startPos + i)
    Next i
    SliceBinary = out
End Function