Bonjour,

Je ne parvient pas Créer une arborescence avec le codage de Monsieur KIKI29.
Comment puis-je m'en sortir je suis nouveau dans ce domaine,
J'ai utilisé son code mais cela ne vas pas.
Au niveau du fichier excel en A2 j'ai remplis comme demandé "Liste Signets"
J'ai Adobe a Pro 2017
Je bloque avec un message
Erreur d’exécution '424' => Objet requis.
Merci

Voici le code

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
Option Explicit
 
Sub Creer_Arborescence()
Dim sDepart As String
Dim sIntermediaire As String
Dim sFinal As String
 
    ' On part d'un document Test.pdf de x pages, vierge de tout signet.
 
    sDepart = ThisWorkbook.Path & "\" & "Test.pdf"
    sIntermediaire = ThisWorkbook.Path & "\" & "Test bmk.pdf"
    sFinal = ThisWorkbook.Path & "\" & "Test bmk Arbo.pdf"
 
    AjoutDonneesExcel_SignetNumPage sDepart, sIntermediaire
    Arborescence_Signets sIntermediaire, sFinal
 
    Kill sIntermediaire
End Sub
 
Private Sub AjoutDonneesExcel_SignetNumPage(sIn As String, sOut As String)
Dim AVDoc As Object
Dim PDDoc As Object
Dim JSO As Object
Dim sStr As String
Dim i As Long
Dim iNum As Long
Dim LastRow As Long
 
    Set AVDoc = CreateObject("AcroExch.AVDoc")
 
    If AVDoc.Open(sIn, "") Then
        Set PDDoc = AVDoc.GetPDDoc
        Set JSO = PDDoc.GetJSObject
 
        LastRow = Feuil1.[ListeSignets].End(xlDown).Row
        For i = 1 To LastRow
            iNum = Feuil1.[ListeSignets].Cells(i, 1) - 1
            sStr = Feuil1.[ListeSignets].Cells(i, 3)
            JSO.bookmarkRoot.createChild sStr, "this.pageNum=" & iNum, iNum
        Next i
 
        With PDDoc
            .Save 1, sOut
            .Close
        End With
 
        Set JSO = Nothing
        Set PDDoc = Nothing
    End If
 
    Set AVDoc = Nothing
End Sub
 
Private Sub Arborescence_Signets(sIn As String, sOut As String)
Dim PDDoc As Object
Dim AVDoc As Object
Dim JSO As Object, bmkRoot As Object
Dim vChildren As Variant, vChildren1 As Variant
Dim i As Long, NbBmk As Long, XNodes(16) As Long
Dim iLev As Long, XLev(16) As Long
 
    Set AVDoc = CreateObject("AcroExch.AVDoc")
 
    If AVDoc.Open(sIn, "") Then
        Set PDDoc = AVDoc.GetPDDoc
        Set JSO = PDDoc.GetJSObject
        Set bmkRoot = JSO.bookmarkRoot
 
        vChildren = bmkRoot.Children
        NbBmk = UBound(vChildren) - LBound(vChildren) + 1
 
        bmkRoot.createChild "Racine Tempo", "", NbBmk
        vChildren = bmkRoot.Children
        XNodes(0) = NbBmk
 
        For i = 1 To 16
            XLev(i) = 0
        Next i
 
        For i = LBound(vChildren) To UBound(vChildren) - 1
            iLev = Feuil1.[ListeSignets].Cells(i + 1, 2)
            XLev(iLev) = XLev(iLev) + 1
            vChildren(XNodes(iLev)).insertchild vChildren(i), XLev(iLev)
            XNodes(iLev + 1) = i
        Next i
 
        vChildren1 = vChildren(XNodes(0)).Children
        For i = LBound(vChildren1) To UBound(vChildren1)
            bmkRoot.insertchild vChildren1(i), i + 1
        Next i
 
        vChildren(XNodes(0)).Remove
 
        With PDDoc
            .Save 1, sOut
            .Close
        End With
 
        Set bmkRoot = Nothing
        Set JSO = Nothing
        Set PDDoc = Nothing
    End If
 
    Set AVDoc = Nothing
    KillAcrobat
End Sub
 
Private Sub KillAcrobat()
Dim RetVal As Long
    RetVal = Shell("Taskkill /im Acrobat.exe /f", 0)
End Sub