Discussion :

[kiki29]

Sur un PC neuf Il peut arriver d'avoir le message "l'ActiveX ne peut pas créer l'objet" lors de l'utilisation de code VBA/PDFCreator après l'installation de ce dernier.

En fait la réponse se trouve dans le fichier Readme.txt situé dans C:\Program Files (x86)\PDFCreator\PlugIns\pdfforge : il faut installer Net FrameWork 2.0 et refaire ensuite l'installation ...
Cela se traduira au final par l'installation du framework 3.5 qui inclut Net 2.0 et 3.0.

[charlie471]

Bonjour.
J’ai besoin de créer des fichiers PDf en série avec des fichiers JPG.
J’ai appliqué votre procédure reproduite ci dessous mais j'ai tout le temps l'erreur active x 429 ne peut pas créer l'objet.
J'ai téléchargé pdf creator 1.7.3 et activé les bibliothèques sous vba....
d’au-celà peut il venir ?
Je suis bloqué.
Merci

PDFCreator Conversion dossier Jpg/Jpeg en PDFs protégés par mots de passe propriétaire/utilisateur

● Très facilement extensible à d'autres types de fichiers.
● Prise en compte des éventuels doublons en les renommant , cela en y ajoutant des indices (1)(2) etc...
● La recherche des fichiers est récursive ou non via True/False dans la procédure SelDossierImages.

ListeFichiers .SelectedItems(1), False

Créer un bouton et l'affecter à la procédure SelDossierImages.

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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
 
Option Explicit
 
Dim Cpt As Long
Dim Tableau() As Variant
Dim TypeFichier(1) As String
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim sDPdfs As String, sDPdfsProt As String
 
Const sNomDossierPdfs As String = "PDFs"
Const sNomDossierPdfsProt As String = "PDFs Protégés"
 
Private Sub CreationDossiers()
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sDPdfs = ThisWorkbook.Path & "\" & sNomDossierPdfs
    sDPdfsProt = ThisWorkbook.Path & "\" & sNomDossierPdfsProt
    If Not FSO.FolderExists(sDPdfs) Then FSO.CreateFolder (sDPdfs)
    If Not FSO.FolderExists(sDPdfsProt) Then FSO.CreateFolder (sDPdfsProt)
    Set FSO = Nothing
End Sub
 
Private Sub CrypterPDF(sNomFichier As String, sOutput As String)
Dim Pdf As Object, Crypt As Object
 
    Set Crypt = CreateObject("pdfforge.Pdf.PDFEncryptor")
 
    With Crypt
        .AllowAssembly = False
        .AllowCopy = False
        .AllowFillIn = False
        .AllowModifyAnnotations = False
        .AllowModifyContents = False
        .AllowPrinting = False
        .AllowPrintingHighResolution = False
        .AllowScreenreaders = False
        '   0:RC4 40 bits
        '   1:RC4 128 bits
        '   2:AES 128 bits
        .EncryptionMethod = 2
        .UserPassword = ""
        .OwnerPassword = "master"
    End With
 
    Set Pdf = CreateObject("pdfforge.Pdf.Pdf")
    Pdf.EncryptPDFFile sNomFichier, sOutput, Crypt
    Set Pdf = Nothing
 
    Set Crypt = Nothing
End Sub
 
Private Sub Jpg2Pdf()
Dim Tools As Object, Pdf As Object, i As Long
Dim s(0) As Variant, sNomFichier As String, sStr As String
Dim FSO As Object, sExt As String, sOut As String
 
    Set Tools = CreateObject("pdfforge.tools")
    Set Pdf = CreateObject("pdfforge.pdf.pdf")
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For i = LBound(Tableau) To UBound(Tableau)
        s(0) = Tableau(i)
        sNomFichier = FSO.GetFileName(s(0))
        sExt = FSO.GetExtensionName(s(0))
        sOut = Left$(sNomFichier, Len(sNomFichier) - Len(sExt)) & "pdf"
        sStr = RenommerFichier(sDPdfs, sOut)
 
'        Public Function Images2PDF ( _
'            ByRef sourceFilenames As Object(), _
'            destinationFilename As String, _
'            scaleMode As Integer _
'        ) As Integer
 
        '   0:La page Pdf s'adaptera à la taille de l'image
        '   1:L'image s'adaptera au format A4
 
        Pdf.Images2PDF_2 s, sStr, 1
        CrypterPDF sStr, sDPdfsProt & "\" & sOut
        Application.StatusBar = i + 1 & " / " & UBound(Tableau) + 1
    Next i
 
    Set FSO = Nothing
    Set Pdf = Nothing
    Set Tools = Nothing
End Sub
 
Private Sub ListeFichiers(sChemin As String, bRecursif As Boolean)
Dim FSO As Object
Dim Dossier As Object
Dim SousDossier As Object
Dim Fichier As Object
Dim i As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sChemin)
 
    For Each Fichier In Dossier.Files
        For i = LBound(TypeFichier) To UBound(TypeFichier)
            If UCase(Fichier.Name) Like UCase(TypeFichier(i)) Then
                ReDim Preserve Tableau(Cpt)
                Tableau(Cpt) = Fichier.Path
                Cpt = Cpt + 1
                Application.StatusBar = Cpt
            End If
        Next i
    Next Fichier
 
    If bRecursif Then
        For Each SousDossier In Dossier.SubFolders
            ListeFichiers SousDossier.Path, True
        Next SousDossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub
 
Private Function RenommerFichier(sChemin As String, sNomFichier As String) As String
Dim sNouveauNom As String
Dim sPre As String
Dim sExt As String
Dim iExt As Long
Dim i As Long, Pos As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.fileExists(sChemin & "\" & sNomFichier) = True Then
        sNouveauNom = sNomFichier
        Pos = InStrRev(sNomFichier, ".")
        iExt = Len(sNomFichier) - Pos + 1
        If Pos > 0 Then
            sExt = Right$(sNomFichier, iExt)
            sPre = Left$(sNomFichier, Len(sNomFichier) - iExt)
        Else
            sExt = ""
            sPre = sNomFichier
        End If
 
        i = 0
        While FSO.fileExists(sChemin & "\" & sNouveauNom) = True
            i = i + 1
            '   sPre(i).sExt
            '   càd ici zaza(1).pdf zaza(2).pdf etc
            sNouveauNom = sPre & Chr(40) & i & Chr(41) & sExt
        Wend
        sNomFichier = sNouveauNom
    End If
    Set FSO = Nothing
 
    RenommerFichier= sChemin & "\" & sNomFichier
End Function
 
Sub SelDossierImages()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Sélection Dossier JPG/JPEG"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            Application.StatusBar = ""
            QueryPerformanceCounter Debut
 
            TypeFichier(0) = "*.jpg"
            TypeFichier(1) = "*.jpeg"
 
            DoEvents
            Cpt = 0
            Erase Tableau
            ' Recherche fichiers récursive ou Non : True/False
            ListeFichiers .SelectedItems(1), False
            If Cpt = 0 Then Exit Sub
 
	    SuppressionDossierPDFsProt
            CreationDossiers
            Jpg2Pdf
            SuppressionDossierPDFs
 
            QueryPerformanceCounter Fin
            QueryPerformanceFrequency Freq
            Application.StatusBar = "Terminé : " & Format((Fin - Debut) / Freq, "0.00 s")
        End If
    End With
End Sub
 
Private Sub SuppressionDossierPDFs()
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sDPdfs = ThisWorkbook.Path & "\" & sNomDossierPdfs
    If FSO.FolderExists(sDPdfs) Then FSO.DeleteFolder (sDPdfs)
    Set FSO = Nothing
End Sub
 
Private Sub SuppressionDossierPDFsProt()
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sDPdfsProt = ThisWorkbook.Path & "\" & sNomDossierPdfsProt
    If FSO.FolderExists(sDPdfsProt) Then FSO.DeleteFolder (sDPdfsProt)
    Set FSO = Nothing
End Sub

[kiki29]

Salut, déjà il s'agit de Late Binding et non d'Early Binding : donc pas de références à cocher .....
Ensuite il y a au post# 301 une réponse possible à ton problème.

[charlie471]

Salut, déjà il s'agit de Late Binding et non d'Early Binding : donc pas de références à cocher .....
Ensuite il y a au post# 301 une réponse possible à ton problème.

J'ai fait la manip sur les bibliothèques comme stipulé dans votre post.
La procédure fonctionne jusqu'au momentd e créer les fichiers pdf avec ce code :

Pdf.ImagesPDF_2 s, sStr, 1
Là je plante systématiquement ...

C'est dommage car je ne suis pas loin d'y arriver et çà me rendrait vraiment service car j'ai énormément de fichier JPG à convertir en PDF en gardant les me^mes noms .

Merci pour votre aide.

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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
 
Option Explicit
 
Dim Cpt As Long
Dim Tableau() As Variant
Dim TypeFichier(1) As String
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim sDPdfs As String, sDPdfsProt As String
 
Const sNomDossierPdfs As String = "PDFs"
Const sNomDossierPdfsProt As String = "PDFs Protégés"
 
Private Sub CreationDossiers()
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sDPdfs = ThisWorkbook.Path & "\" & sNomDossierPdfs
    sDPdfsProt = ThisWorkbook.Path & "\" & sNomDossierPdfsProt
    If Not FSO.FolderExists(sDPdfs) Then FSO.CreateFolder (sDPdfs)
    If Not FSO.FolderExists(sDPdfsProt) Then FSO.CreateFolder (sDPdfsProt)
    Set FSO = Nothing
End Sub
 
Private Sub CrypterPDF(sNomFichier As String, sOutput As String)
Dim Pdf As Object, Crypt As Object
 
    Set Crypt = CreateObject("pdfforge.Pdf.PDFEncryptor")
 
    With Crypt
        .AllowAssembly = False
        .AllowCopy = False
        .AllowFillIn = False
        .AllowModifyAnnotations = False
        .AllowModifyContents = False
        .AllowPrinting = False
        .AllowPrintingHighResolution = False
        .AllowScreenreaders = False
        '   0:RC4 40 bits
        '   1:RC4 128 bits
        '   2:AES 128 bits
        .EncryptionMethod = 2
        .UserPassword = ""
        .OwnerPassword = "master"
    End With
 
    Set Pdf = CreateObject("pdfforge.Pdf.Pdf")
    Pdf.EncryptPDFFile sNomFichier, sOutput, Crypt
    Set Pdf = Nothing
 
    Set Crypt = Nothing
End Sub
 
Private Sub Jpg2Pdf()
Dim Tools As Object, Pdf As Object, i As Long
Dim s(0) As Variant, sNomFichier As String, sStr As String
Dim FSO As Object, sExt As String, sOut As String
 
    Set Tools = CreateObject("PDFCreator.clsPDFCreator")
    Set Pdf = CreateObject("pdfforge.Pdf.Pdf")
 
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For i = LBound(Tableau) To UBound(Tableau)
        s(0) = Tableau(i)
        sNomFichier = FSO.GetFileName(s(0))
        sExt = FSO.GetExtensionName(s(0))
        sOut = Left$(sNomFichier, Len(sNomFichier) - Len(sExt)) & "pdf"
        sStr = RenommerFichier(sDPdfs, sOut)
 
'        Public Function Images2PDF ( _
'            ByRef sourceFilenames As Object(), _
'            destinationFilename As String, _
'            scaleMode As Integer _
'        ) As Integer
 
        '   0:La page Pdf s'adaptera à la taille de l'image
        '   1:L'image s'adaptera au format A4
 
        Pdf.ImagesPDF_2 s, sStr, 1
        CrypterPDF sStr, sDPdfsProt & "\" & sOut
        Application.StatusBar = i + 1 & " / " & UBound(Tableau) + 1
    Next i
 
    Set FSO = Nothing
    Set Pdf = Nothing
    Set Tools = Nothing
End Sub
 
Private Sub ListeFichiers(sChemin As String, bRecursif As Boolean)
Dim FSO As Object
Dim Dossier As Object
Dim SousDossier As Object
Dim Fichier As Object
Dim i As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sChemin)
 
    For Each Fichier In Dossier.Files
        For i = LBound(TypeFichier) To UBound(TypeFichier)
            If UCase(Fichier.Name) Like UCase(TypeFichier(i)) Then
                ReDim Preserve Tableau(Cpt)
                Tableau(Cpt) = Fichier.Path
                Cpt = Cpt + 1
                Application.StatusBar = Cpt
            End If
        Next i
    Next Fichier
 
    If bRecursif Then
        For Each SousDossier In Dossier.SubFolders
            ListeFichiers SousDossier.Path, True
        Next SousDossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub
 
Private Function RenommerFichier(sChemin As String, sNomFichier As String) As String
Dim sNouveauNom As String
Dim sPre As String
Dim sExt As String
Dim iExt As Long
Dim i As Long, Pos As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.fileExists(sChemin & "\" & sNomFichier) = True Then
        sNouveauNom = sNomFichier
        Pos = InStrRev(sNomFichier, ".")
        iExt = Len(sNomFichier) - Pos + 1
        If Pos > 0 Then
            sExt = Right$(sNomFichier, iExt)
            sPre = Left$(sNomFichier, Len(sNomFichier) - iExt)
        Else
            sExt = ""
            sPre = sNomFichier
        End If
 
        i = 0
        While FSO.fileExists(sChemin & "\" & sNouveauNom) = True
            i = i + 1
            '   sPre(i).sExt
            '   càd ici zaza(1).pdf zaza(2).pdf etc
            sNouveauNom = sPre & Chr(40) & i & Chr(41) & sExt
        Wend
        sNomFichier = sNouveauNom
    End If
    Set FSO = Nothing
 
    RenommerFichier = sChemin & "\" & sNomFichier
End Function
 
Sub SelDossierImages()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Sélection Dossier JPG/JPEG"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            Application.StatusBar = ""
            QueryPerformanceCounter Debut
 
            TypeFichier(0) = "*.jpg"
            TypeFichier(1) = "*.jpeg"
 
            DoEvents
            Cpt = 0
            Erase Tableau
            ' Recherche fichiers récursive ou Non : True/False
            ListeFichiers .SelectedItems(1), True
            If Cpt = 0 Then Exit Sub
 
        SuppressionDossierPDFsProt
            CreationDossiers
            Jpg2Pdf
            SuppressionDossierPDFs
 
            QueryPerformanceCounter Fin
            QueryPerformanceFrequency Freq
            Application.StatusBar = "Terminé : " & Format((Fin - Debut) / Freq, "0.00 s")
        End If
    End With
End Sub
 
Private Sub SuppressionDossierPDFs()
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sDPdfs = ThisWorkbook.Path & "\" & sNomDossierPdfs
    If FSO.FolderExists(sDPdfs) Then FSO.DeleteFolder (sDPdfs)
    Set FSO = Nothing
End Sub
 
Private Sub SuppressionDossierPDFsProt()
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sDPdfsProt = ThisWorkbook.Path & "\" & sNomDossierPdfsProt
    If FSO.FolderExists(sDPdfsProt) Then FSO.DeleteFolder (sDPdfsProt)
    Set FSO = Nothing
End Sub

[kiki29]

Salut, par pitié Balise ton code

Sinon dans Private Sub Jpg2Pdf remplace

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Pdf.ImagesPDF_2 s, sStr, 1

par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Pdf.Images2PDF_2 s, sStr, 1

De fait la réponse était sous tes yeux :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
' Public Function Images2PDF ( _
' ByRef sourceFilenames As Object(), _
' destinationFilename As String, _
' scaleMode As Integer _
' ) As Integer

[charlie471]

Re/...

effectivement ja'i changé le nom en inversant le 2... mais maintenant j'ai une erreur incompatibilité.
La variable S est de type variant alors que dans les rq au dessus il semblerait qu'il faille que ce soit un objet. je n'arrive pas à la déclarer en tant qu'objet !

Salut, par pitié Balise ton code

Sinon dans Private Sub Jpg2Pdf remplace

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Pdf.ImagesPDF_2 s, sStr, 1

par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Pdf.Images2PDF_2 s, sStr, 1

De fait la réponse était sous tes yeux :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
' Public Function Images2PDF ( _
' ByRef sourceFilenames As Object(), _
' destinationFilename As String, _
' scaleMode As Integer _
' ) As Integer

[charlie471]

J'ai trouvé", j'avais oublié le deuxième 2 après _...


Merci beaucoup çà fonctionne très bien.
Je vais pouvoir transformer tous mes JPG en pdf en un seul clic ...
Super et bravo pour vos compétences.

Re/...

effectivement ja'i changé le nom en inversant le 2... mais maintenant j'ai une erreur incompatibilité.
La variable S est de type variant alors que dans les rq au dessus il semblerait qu'il faille que ce soit un objet. je n'arrive pas à la déclarer en tant qu'objet !

[kiki29]

A titre d'info téléchargements disponibles ici :
Conversion d'un dossier Images en PDFs protégés par mots de passe via PDFCreator
Conversion d'un dossier Images en PDFs via PDFCreator

● Prise en compte des formats : bmp emf gif jfif jpe jpeg jpg png tif tiff wmf
● Prise en compte des éventuels doublons
● Recherche des fichiers récursive ou non.
● FSO remplacé par APIs

[kiki29]

Suite du post # 92 du 01/05/2014.

Pour supprimer le message : "Une erreur est survenue lors de l'ouverture de ce document. Fichier introuvable"
Dans les préférences du Reader : Protection (renforcée) décocher "Activer le mode protégé au démarrage"

[kiki29]

Pour cela voir ici

[DJSn0w00b]

[B]PDFCreator

Fusion des PDF d'un Dossier
Affecter un bouton à SelDossierFusion
Procédure récursive ou non

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Option Explicit
 
Dim Cpt As Long
Dim Tableau() As Variant
Const TypeFichier As String = "*.pdf"
 
Private Sub Fusion()
Dim Pdf As Object
    Set Pdf = CreateObject("pdfforge.pdf.pdf")
    Pdf.MergePDFFiles_2 Tableau, ThisWorkbook.Path & "\" & "Fusion Dossier.pdf", True
    Set Pdf = Nothing
End Sub

Bonjour,

Tout d'abord merci pour toutes ces fonctionnalités PDF sous VBA, ca aide beaucoup !
J'ai utilisé le code concernant la fusion des PDF d'un dossier et j'ai un petit problème.
La fusion se passe bien par contre si je fusionne des fichiers pdf avec des liens hypertextes, ces liens ne sont plus fonctionnels (désactivés) dans le pdf fusionné.
Est-ce un comportement normal ?
Est-ce qu'il existe des options qui permettraient de conserver les liens hypertextes après la fusion ?

Merci d'avance pour votre aide,

Cordialement

[kiki29]

Salut, malheureusement il faut faire avec, seul les liens style url sont pris en compte.
Sinon il faudrait passer par Acrobat ( pas le Reader ) et JavaScript : un exemple extrait de la doc de référence d'Acrobat : recherche un mot dans un PDF, encadre et crée un lien (ici vers un site web) pour chaque occurrence trouvée de ce mot.

[kiki29]

Toujours utile : le Tutoriel PDFCreator-Serveur de Tristan FLEURY concernant : Installation et paramétrage de PDFCreator en mode serveur

[alexgo]

MErci beaucoup ca à l'air d'etre exactement ce que je cherche pour fusionner différents pdf extrait via des états ACCESS placé dans un même dossier mais je n'y connait tellement rien en VBA que je ne comprend ce que je dois modifié (élément rouge je suppose) et remplacé par quoi???
Pourriez vous m'éclairer svp
merci d'avance

PDFCreator Fusion de fichiers PDF

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
 
Option Explicit
 
Sub Fusion()
Dim Pdf As Object, Fichiers(2)
    Set Pdf = CreateObject("pdfforge.pdf.pdf")
 
    Fichiers(0) = ThisWorkbook.Path & "\" & "1.pdf"
    Fichiers(1) = ThisWorkbook.Path & "\" & "2.pdf"
    Fichiers(2) = ThisWorkbook.Path & "\" & "3.pdf"
 
    Pdf.MergePDFFiles_2 Fichiers, ThisWorkbook.Path & "\" & "Fusion.pdf", True
 
    Set Pdf = Nothing
End Sub

Fusion des PDF d'un Dossier
Affecter un bouton à SelDossierFusion
Procédure récursive ou non

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
Option Explicit
 
Dim Cpt As Long
Dim Tableau() As Variant
Const TypeFichier As String = "*.pdf"
 
Private Sub Fusion()
Dim Pdf As Object
    Set Pdf = CreateObject("pdfforge.pdf.pdf")
    Pdf.MergePDFFiles_2 Tableau, ThisWorkbook.Path & "\" & "Fusion Dossier.pdf", True
    Set Pdf = Nothing
End Sub
 
Private Sub ListeFichiers(ByVal sChemin As String, ByVal Recursif As Boolean)
Dim FSO As Object
Dim Dossier As Object
Dim SousDossier As Object
Dim Fichier As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sChemin)
 
    For Each Fichier In Dossier.Files
        If UCase(Fichier.Name) Like UCase(TypeFichier) Then
            ReDim Preserve Tableau(Cpt)
            Tableau(Cpt) = Fichier.Path
            Cpt = Cpt + 1
            Application.StatusBar = Cpt
        End If
    Next Fichier
 
    If Recursif Then
        For Each SousDossier In Dossier.SubFolders
            ListeFichiers SousDossier.Path, True
        Next SousDossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub
 
Sub SelDossierFusion()
Dim sChemin As String
 
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner un Dossier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            Application.StatusBar = ""
            DoEvents
            Cpt = 0
            Erase Tableau
           '    ListeFichiers récursive ou non True/False
            ListeFichiers .SelectedItems(1), True
            Fusion
        End If
    End With
End Sub

[kiki29]

Salut, tout est écrit après plus je ne vois pas

Fusion des PDF d'un Dossier
Affecter un bouton à SelDossierFusion
Procédure récursive ou non

Sinon il suffit de chercher dans la liste des contributions où une appli remplit cette fonction de fusion des PDFs d'un dossier via PDFCreator / Excel avec les choix du dossier à fusionner,du nom du fichier fusionné et une gestion des doublons éventuels.

Il existe dans cette liste une autre appli pour Adobe Acrobat

[kiki29]

Suite à ce post

une version plus élaborée de : Acrobat Lecture d'infos et métadonnées d'un fichier PDF est en Téléchargement ici

[kiki29]

Placer l'utilitaire pdfdetach.exe ( renommé ici en pdfdetach32.exe ) dans le dossier de l'appli.
Cet utilitaire est dans xpdfbin-win-3.04.zip

Les pièces jointes du pdf sélectionné seront extraites dans un dossier par défaut : ici nommé "Pièces Jointes"
Ce dossier est créé s'il n'existe pas.

Appli en téléchargement ici

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
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub ExtractionPJ(ByVal sFichier)
Dim Wsh As Object, sCheminAppli As String, sDossierPJ As String
    sCheminAppli = ThisWorkbook.Path & "\" & "pdfdetach32.exe"
    sDossierPJ = ThisWorkbook.Path & "\" & "Pièces Jointes"
    CreationDossier sDossierPJ
    Set Wsh = CreateObject("WScript.Shell")
    Wsh.Exec (sCheminAppli & Chr(32) & Chr(34) & sFichier & Chr(34) & " -saveall -o " & Chr(34) & sDossierPJ)
    Set Wsh = Nothing
End Sub
 
Sub SelectionFichier()
Dim FD As FileDialog
 
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "PDF", "*.pdf", 1
        .ButtonName = "Ouvrir fichier"
        .Title = "Sélectionner un fichier PDF"
    End With
 
    If FD.Show = True Then
        DoEvents
        Application.StatusBar = ""
        ExtractionPJ FD.SelectedItems(1)
    End If
 
    Set FD = Nothing
End Sub

[kiki29]

On peut également gérer les dossiers en doublons : par défaut les fichiers extraits seront groupés dans un dossier prenant le nom du pdf dont ils sont extraits.
Voir la copie d'écran : le doc s'appelle ici PJ.pdf et le dossier créé PJ et les doublons éventuels PJ(001) PJ(002) etc.

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
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub ExtractionPJ(ByVal sFichier)
Dim Wsh As Object, sCheminAppli As String
Dim sCheminDossierPJ As String, sNomDossierPJ As String
Dim FSO As Object, sNomDossier As String
 
    sCheminAppli = ThisWorkbook.Path & "\" & "pdfdetach32.exe"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sNomDossierPJ = FSO.GetBaseName(sFichier)
    Set FSO = Nothing
 
    sCheminDossierPJ = ThisWorkbook.Path
    sNomDossier = RenommerDossier(sCheminDossierPJ, sNomDossierPJ)
 
    Set Wsh = CreateObject("WScript.Shell")
    Wsh.Exec (sCheminAppli & Chr(32) & Chr(34) & sFichier & Chr(34) & " -saveall -o " & Chr(34) & sNomDossier)
    Set Wsh = Nothing
End Sub
 
Private Function RenommerDossier(ByVal sChemin As String, ByVal sDossier As String) As String
Dim sNouveauNom As String, sNomDossier As String
Dim i As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(sChemin & "\" & sDossier) Then
        sNouveauNom = sDossier
        i = 0
        While FSO.FolderExists(sChemin & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sDossier & Chr(40) & Format(i, "000") & Chr(41)
        Wend
        sNomDossier = sNouveauNom
    Else
        sNomDossier = sDossier
    End If
    Set FSO = Nothing
 
    CreationDossier sChemin & "\" & sNomDossier
    RenommerDossier = sChemin & "\" & sNomDossier
End Function
 
Sub SelectionFichier()
Dim FD As FileDialog
 
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "PDF", "*.pdf", 1
        .ButtonName = "Ouvrir fichier"
        .Title = "Sélectionner un fichier PDF"
    End With
 
    If FD.Show = True Then
        DoEvents
        Application.StatusBar = ""
        ExtractionPJ FD.SelectedItems(1)
    End If
 
    Set FD = Nothing
End Sub

Appli en téléchargement ici

[kiki29]

Placer l'utilitaire pdfimages.exe ( renommé ici en pdfimages32.exe ) dans le dossier de l'appli.
Cet utilitaire est dans xpdfbin-win-3.04.zip

Le pdf sélectionné sera converti dans un dossier par défaut : ici nommé "Images"
Ce dossier est créé, s'il n'existe pas, à la racine de l'appli.
Les fichiers extraits portent comme nom le préfixe du fichier pdf sélectionné.

Appli en téléchargement ici
A rapprocher de PDFCreator Extraction des Images d'un fichier PDF

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
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub PDF2Images(ByVal sFichier)
Dim Wsh As Object, sCheminAppli As String, sDossierImages As String
Dim sNomFichierPS As String, sPre As String, FSO As Object, sNomImages As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sPre = FSO.GetBaseName(sFichier)
    Set FSO = Nothing
 
    sCheminAppli = ThisWorkbook.Path & "\" & "pdfimages32.exe"
 
    sDossierImages = ThisWorkbook.Path & "\" & "Images"
    CreationDossier sDossierImages
    sNomImages = sDossierImages & "\" & sPre
 
    Set Wsh = CreateObject("WScript.Shell")
    Wsh.Exec (sCheminAppli & Chr(32) & Chr(34) & sFichier & Chr(34) & " -j " & Chr(34) & sNomImages)
    Set Wsh = Nothing
End Sub
 
Sub SelectionFichier()
Dim FD As FileDialog
 
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "PDF", "*.pdf", 1
        .ButtonName = "Ouvrir fichier"
        .Title = "Sélectionner un fichier PDF"
    End With
 
    If FD.Show = True Then
        DoEvents
        Application.StatusBar = ""
        PDF2Images FD.SelectedItems(1)
    End If
 
    Set FD = Nothing
End Sub

[kiki29]

Placer l'utilitaire pdftohtml.exe ( renommé ici en pdftohtml32.exe ) dans le dossier de l'appli.
Cet utilitaire est dans xpdfbin-win-3.04.zip

Le pdf sélectionné sera converti dans un dossier par défaut : ici nommé "HTML"
Ce dossier est créé, s'il n'existe pas, à la racine de l'appli.
De même pour le sous dossier homonyme du pdf qui contiendra les pages html dans le dossier HTML.

Appli en téléchargement ici

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
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub PDF2Html(ByVal sFichier)
Dim Wsh As Object, sCheminAppli As String, sDossierHTML As String
Dim sNomFichierPS As String, sPre As String, FSO As Object, sDossierSecondaireHtml As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sPre = FSO.GetBaseName(sFichier)
    Set FSO = Nothing
 
    sCheminAppli = ThisWorkbook.Path & "\" & "pdftohtml32.exe"
    sDossierHTML = ThisWorkbook.Path & "\" & "HTML"
    CreationDossier sDossierHTML
 
    sDossierSecondaireHtml = sDossierHTML & "\" & sPre
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(sDossierSecondaireHtml) Then FSO.DeleteFolder sDossierSecondaireHtml, True
    Set FSO = Nothing
 
    Set Wsh = CreateObject("WScript.Shell")
    Wsh.Exec (sCheminAppli & Chr(32) & Chr(34) & sFichier & Chr(34) & " -r 72 " & Chr(34) & sDossierSecondaireHtml)
    Set Wsh = Nothing
End Sub
 
Sub SelectionFichier()
Dim FD As FileDialog
 
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "PDF", "*.pdf", 1
        .ButtonName = "Ouvrir fichier"
        .Title = "Sélectionner un fichier PDF"
    End With
 
    If FD.Show = True Then
        DoEvents
        Application.StatusBar = ""
        PDF2Html FD.SelectedItems(1)
    End If
 
    Set FD = Nothing
End Sub