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

[Dudu2]

Bonjour,

Je n'utilise généralement pas Adobe Acrobat pour visualiser les PDF, lui préférant PDF-XChange Viewer plus léger et moins invasif.
Cependant l'ayant installé, il créé de nombreux problèmes avec les PDF intégrés (embbeded).

Ce logiciel intrusif modifie les propriétés du PDF embbeded et rend impossible l'ouverture par un autre logiciel qu'Acrobat alors que sous PDF-XChange Viewer, le PDF embbeded peut être ouvert par n'importe quel PDF Viewer.
De plus il faut désactiver le "Mode protégé au démarrage" (Acrobat / Menu / Préférence / Protection (renforcée) / Décocher "Activer le mode protégé au démarrage") pour visualiser les PDF embbeded.

Si j'arrive sans problème à enregistrer en fichier un PDF qui a été intégré (embbeded) en l'absence d'Adobe Acrobat sur le PC (seulement PDF-XChange Viewer), je n'y arrive pas lorsque le PDF a été intégré (embbeded) en présence d'Adobe Acrobat sur le PC.

La question: comment enregistrer en fichier un PDF qui a été intégré (embbeded) en présence d'Adobe Acrobat sur le PC ? (Voir le fichier joint).
Ou alors comment modifier les propriétés du PDF embbeded pour qu'il soit ouvrable par n'importe quel PDF Viewer ?

Justification: en enregistrant en fichier le PDF intégré en présence d'Acrobat, on pourrait alors le lancer quelque soit le PDF Viewer installé.

 

[Dudu2]

En fait nul besoin de renommer le .bin en .txt !

'-------------------------------------------------------------------
'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

 

[patricktoulon]

et ben voila
mais perso je n'ai jamais dit qu'il fallait le renommer tu le lit c'est tout
c'est juste un poil plus long avec open for surtout si les pdf font +> de 1/2 mega

explications sur:

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

la collection items d'un namespace n'a tout simplement pas d'indexation puisqu'elle est tributaire du shell window et donc liste les elements tels qu'il sont lister dans l'explorer
et puis c'est pas items(abcdef...) c'est items.item(abcdef...)
donc explicitement tu peux l'avoir par son nom

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

et comme tu sais tres bien le job a faire tu peux reduire a ceci

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

et si tu veux savoir tout ce que tu peux faire avec tes fichiers du zip dossier embeddings
testé avec ton fichier

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

Patrick

 

[Dudu2]

Ok, merci pour l'explication.
Je ne sais pas si je risque un

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

ou si je garde la boucle qui ne fait pas de présupposé.

 

[patricktoulon]

a ben c'est sur qu'une boucle est mieux dans le sens ou tu n'a pas besoins de connaitre le nom
je t'ai juste donné cet exemple pour te montrer comment on chope unitairement un fichier de l'archive ou un dossier d'ailleurs aussi


Set dossierquejeveux= objectshell.namespace(cheminduzip & "\undossier").items.item("unsubdossier")

set fichierquejeveux= objectshell.namespace(cheminduzip & "\undossier\unsubdossier\unautresubdossier").items.item("tartempion.jpeg")
en gros dans la parenthèse du namespace tu dois avoir le chemin du dossier ou fichier sans le dossier ou fichier
et le dossier ou fichier que tu veux recupérer tu le met dans la parenthèse du item
pas compliqué
je t'ai édité mon précédent message avec une sub testx3 qui te permet de voir tout ce qu'il t'est possible de faire avec un des element du zip
notamment les action verb de la même maniere que tu le fait avec tes object dans la feuille

voila tu sais tout

Patrick

 

[Dudu2]

J'ai une petite question complémentaire...
Peut-on savoir en VBA si l'Embbeded Object est issu d'Acrobat ou pas ?

Visuellement on peut faire la différence en clic droit:
Acrobat:

Standard:

 

[patricktoulon]

re
et bien dans ce cas la tu peut tenter un select de l'oleobject et lister les controls de la popup
tu veux que je fasse un essais

 

[patricktoulon]

re
voila terminé

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

bien vu l'idée du menu 😉

Patrick

 

[Dudu2]

Merci @patricktoulon mais chez moi ça ne donne rien.
J'ai toujours Faux.

Voilà ce que je récolte.
Object 2 = Faux
Cou&per
&Copier
C&oller
O&bjet Objet d’environnement du Gestionnaire de liaisons
&Regroupement
Or&dre
Affecter u&ne macro...
Mise en forme de l’ob&jet...

Object 4 = Faux
Cou&per
&Copier
C&oller
O&bjet Objet d’environnement du Gestionnaire de liaisons
&Regroupement
Or&dre
Affecter u&ne macro...
Mise en forme de l’ob&jet...