Salut, effectivement il te faut Acrobat Pro ( payant dans les 650 € ), mais qu'importe la version d'Excel.
Salut, effectivement il te faut Acrobat Pro ( payant dans les 650 € ), mais qu'importe la version d'Excel.
Même si ta réponse ne me convient pas je te remercie je vais devoir faire autrement du coup...
Merci et pour info, même si j'ai pas ce qu'il faut, je suis tes différents post ici avec intérêt
- Avant de poster, et http://www.developpez.com/sources/
- Lors du post, n'oubliez pas, si besoin les balises CODE => voir ici pour l'utilisation
- N'oubliez pas le
- N'oubliez pas le si la réponse vous a été utile !
Acrobat Pro OCR : problèmes avec certains PDF
Une discussion intéressante sur l'OCR et les fichiers PDF :
quand ces derniers contiennent un texte partiellement éditable et que ni l'OCR ni
le copier/coller ne fonctionnent correctement.
Une liste des contributions à jour pour Excel / Word / PDF avec Adobe Acrobat Pro et PDFCreator au 15 Juillet 2014 au format xls avec les liens et intitulés des différents posts
PS : Les colonnes D et E sont masquées et contiennent les infos nécessaires pour créer les liens dans la colonne B.
PDFCreator Taille d'un 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 Option Explicit Private Sub LectureTaille(sNomfichier As String) Dim pdf As Object, iMo As Long Set pdf = CreateObject("pdfforge.Pdf.Pdf") iMo = pdf.FileLength(sNomfichier) / 1048576 MsgBox "Taille : " & Format(pdf.FileLength(sNomfichier), "# ### ###") & " Octets" Set pdf = Nothing End Sub Sub SelFichier() Dim Fichier As Variant ChDir ThisWorkbook.Path & "\" Fichier = Application.GetOpenFilename("Fichiers PDF (*.Pdf), *.Pdf") If Fichier = False Then Exit Sub DoEvents LectureTaille (Fichier) End Sub
PDFCreator Extraction de pages d'un catalogue Pdf et insertion de ces Pdf en réduction dans un Doc Word
pour la version Excel voir Post 25
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 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 sOut As String Dim TabPages() As Long, Tablo() As String Dim NbPagesEnHorizontal As Long Dim Deb As Currency, Fin As Currency, Freq As Currency Sub DelAllShapes() Dim oIls As InlineShape Dim oShp As Shape For Each oShp In ThisDocument.Shapes oShp.Delete Next oShp For Each oIls In ThisDocument.InlineShapes oIls.Delete Next oIls End Sub Private Sub ExtractionPDF(sNom As String, iNumPage As Long) Dim Pdf As Object Set Pdf = CreateObject("pdfforge.pdf.pdf") Pdf.CopyPDFFile sNom, sOut, iNumPage, iNumPage Set Pdf = Nothing End Sub Private Sub InsertionPDF(ByVal SNomFichier As String) Dim i As Long DelAllShapes PagesAImporter sOut = ThisDocument.Path & "\" & "Extraction.pdf" For i = UBound(TabPages) To LBound(TabPages) Step -1 ExtractionPDF SNomFichier, TabPages(i) ThisDocument.InlineShapes.AddOLEObject FileName:=sOut Application.StatusBar = i + 1 Next i Kill sOut End Sub Private Sub PagesAImporter() Dim NbPages As Long NbPages = 8 NbPagesEnHorizontal = 3 Erase TabPages Erase Tablo ReDim TabPages(NbPages - 1) ReDim Tablo(NbPages - 1) TabPages(0) = 1 TabPages(1) = 2 TabPages(2) = 3 TabPages(3) = 4 TabPages(4) = 5 TabPages(5) = 6 TabPages(6) = 7 TabPages(7) = 8 End Sub Sub PosShapes() Dim oShp As Shape Dim i As Long, n As Long Dim L As Double, W As Double Dim T As Double, H As Double Dim Pas As Double, Marge As Double Dim Coeff As Double n = ThisDocument.InlineShapes.Count If n = 0 Then Exit Sub Application.ScreenUpdating = False For i = n To 1 Step -1 ThisDocument.InlineShapes(i).Select Set oShp = ThisDocument.InlineShapes(i).ConvertToShape Tablo(i - 1) = oShp.Name Application.StatusBar = i & " / " & n Next i Set oShp = Nothing With ThisDocument.Shapes(Tablo(0)) W = .Width H = .Height Coeff = H / W End With W = Application.CentimetersToPoints(5) H = W * Coeff Pas = Application.CentimetersToPoints(0.25) Marge = Application.CentimetersToPoints(0.5) For i = LBound(Tablo) To UBound(Tablo) L = Marge + (i Mod NbPagesEnHorizontal) * (W + Pas) T = Marge + (i \ NbPagesEnHorizontal) * (H + Pas) With ThisDocument.Shapes(Tablo(i)) .Left = L .Top = T .Width = W .Height = H End With Next i Application.ScreenUpdating = True End Sub Sub SelectionFichier() Dim Dial As FileDialog, s As Double ChDir ThisDocument.Path & "\" Set Dial = Application.FileDialog(FileDialogType:=msoFileDialogOpen) With Dial .AllowMultiSelect = False .Filters.Add "Fichiers PDF", "*.pdf", 1 If .Show = -1 Then DoEvents QueryPerformanceCounter Deb InsertionPDF .SelectedItems(1) PosShapes QueryPerformanceCounter Fin QueryPerformanceFrequency Freq s = (Fin - Deb) / Freq Application.StatusBar = Format(s, "0.00 s") End If End With Set Dial = Nothing End Sub
Acrobat Extraction de pages d'un catalogue Pdf et insertion de ces Pdf en réduction dans un Doc Word
pour la version Excel voir Post 86
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 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 sOut As String Dim TabPages As Variant, Tablo() As String Dim NbPagesEnHorizontal As Long Dim Deb As Currency, Fin As Currency, Freq As Currency Sub DelAllShapes() Dim oIls As InlineShape Dim oShp As Shape For Each oShp In ThisDocument.Shapes oShp.Delete Next oShp For Each oIls In ThisDocument.InlineShapes oIls.Delete Next oIls End Sub Private Sub InsertionPDF(ByVal sNomFichier As String) Dim i As Long DelAllShapes PagesAImporter sOut = ThisDocument.Path & "\" & "Extraction.pdf" For i = UBound(TabPages) To LBound(TabPages) Step -1 Split_Fichier sNomFichier, TabPages(i) ThisDocument.InlineShapes.AddOLEObject FileName:=sOut Application.StatusBar = i + 1 Next i Kill sOut End Sub Private Sub PagesAImporter() NbPagesEnHorizontal = 3 TabPages = Array(1, 2, 3, 4, 5, 6, 7, 8) Erase Tablo ReDim Tablo(UBound(TabPages)) End Sub Sub PosShapes() Dim oShp As Shape Dim i As Long, n As Long Dim L As Double, W As Double Dim T As Double, H As Double, Pas As Double, Marge As Double Dim Coeff As Double n = ThisDocument.InlineShapes.Count If n = 0 Then Exit Sub Application.ScreenUpdating = False For i = n To 1 Step -1 ThisDocument.InlineShapes(i).Select Set oShp = ThisDocument.InlineShapes(i).ConvertToShape Tablo(i - 1) = oShp.Name Application.StatusBar = i & " / " & n Next i Set oShp = Nothing With ThisDocument.Shapes(Tablo(0)) W = .Width H = .Height Coeff = H / W End With W = Application.CentimetersToPoints(5) H = W * Coeff Pas = Application.CentimetersToPoints(0.25) Marge = Application.CentimetersToPoints(0.5) For i = LBound(Tablo) To UBound(Tablo) L = Marge + (i Mod NbPagesEnHorizontal) * (W + Pas) T = Marge + (i \ NbPagesEnHorizontal) * (H + Pas) With ThisDocument.Shapes(Tablo(i)) .Left = L .Top = T .Width = W .Height = H End With Next i Application.ScreenUpdating = True End Sub Sub SelectionFichier() Dim Dial As FileDialog, s As Double ChDir ThisDocument.Path & "\" Set Dial = Application.FileDialog(FileDialogType:=msoFileDialogOpen) With Dial .AllowMultiSelect = False .Filters.Add "Fichiers PDF", "*.pdf", 1 If .Show = -1 Then DoEvents QueryPerformanceCounter Deb InsertionPDF .SelectedItems(1) PosShapes QueryPerformanceCounter Fin QueryPerformanceFrequency Freq s = (Fin - Deb) / Freq Application.StatusBar = Format(s, "0.00 s") End If End With Set Dial = Nothing End Sub Private Sub Split_Fichier(ByVal sNomFichier As String, ByVal iNb As Long) Dim PDDocSource As Object Dim PDDocDestination As Object Dim sNomPdf As String Set PDDocSource = CreateObject("AcroExch.PDDoc") PDDocSource.Open sNomFichier Set PDDocDestination = CreateObject("AcroExch.PDDoc") PDDocDestination.Create sNomPdf = sOut 'nInsertPageAfter ' La page du document Destination après laquelle les pages du document Source seront insérées. ' La 1ere page d'un document est la page 0. 'iPDDocSource ' Le document Source contenant les pages à insérer. 'nStartPage ' La 1ere page a être insérée dans le document Destination. 'nNumPages ' Le nombre de pages à insérer. 'bBookmarks ' Si le nombre est positif alors les signets du document Source sont copiés. ' Si 0, alors non. With PDDocDestination .InsertPages -1, PDDocSource, iNb - 1, 1, 0 .Save 1, sNomPdf .Close End With Set PDDocDestination = Nothing Set PDDocSource = Nothing End Sub
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
PDFCreator Conversion dossier Images en PDFs protégés par mots de passe propriétaire/utilisateur
● Prise en compte des formats : bmp emf gif jfif jpe jpeg jpg png tif tiff wmf
● Prise en compte des éventuels doublons.
● La recherche des fichiers est récursive ou non.
● Plus véloce que la précédente : FSO remplacé par APIs.
○ Créer un bouton "btnSelect" et l'affecter à la procédure SelDossierImages du module mImages2Pdf.
○ Créer une case à cocher "chkRecur".
○ Créer 2 plages nommées "MdpUser" et "MdpOwner".
○ La feuille comportant "btnSelect" "chkRecur" "MdpUser" et "MdpOwner" à un CodeName de "shParam"
Ajouter dans un module standard baptisé mGlob
Ajouter dans un module standard baptisé mImages2Pdf
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5 Option Explicit Public TableauFichiers() As String Public TypeFichier(11) As String Public Cpt As Long
Ajouter dans un module standard baptisé mFichiers
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
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223 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 Debut As Currency, Fin As Currency, Freq As Currency Dim sDPdfs As String, sDPdfsProt As String Dim bRecursif As Boolean 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 ' Acrobat 6.0 et versions ultérieures (PDF 1.5) permet de chiffrer le document ' au moyen du chiffrement RC4 à 128 bits. ' Acrobat 7.0 et versions ultérieures (PDF 1.6) permet de chiffrer le document ' au moyen du chiffrement AES 128 bits. ' Acrobat X et versions ultérieures (PDF 1.7) permet de chiffrer le document ' au moyen du chiffrement AES à 256 bits. .EncryptionMethod = 2 .UserPassword = shParam.Range("MdpUser") .OwnerPassword = shParam.Range("MdpOwner") End With ' Public Function EncryptPDFFile( _ ' sourceFilename As String, _ ' destinationFilename As String, _ ' ByRef enc As PDFEncryptor _ ' ) As Integer Set Pdf = CreateObject("pdfforge.Pdf.Pdf") Pdf.EncryptPDFFile sNomFichier, sOutput, Crypt Set Pdf = Nothing Set Crypt = Nothing End Sub Private Sub Images2Pdf() Dim Tools As Object, Pdf As Object, i As Long Dim s(0) As String, sNomFichier As String, sNouveauNom 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(TableauFichiers) To UBound(TableauFichiers) s(0) = TableauFichiers(i) sNomFichier = FSO.GetFileName(s(0)) sExt = FSO.GetExtensionName(s(0)) sOut = Left$(sNomFichier, Len(sNomFichier) - Len(sExt)) & "pdf" sNouveauNom = 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 s, sNouveauNom, 1 CrypterPDF sNouveauNom, sDPdfsProt & "\" & sOut Application.StatusBar = i + 1 & " / " & UBound(TableauFichiers) + 1 DoEvents Next i Set FSO = Nothing Set Pdf = Nothing Set Tools = Nothing End Sub Private Sub PosBoutons() Dim T As Range With shParam .Activate .Rows(1).RowHeight = 40 Set T = .Cells(1, 3) With .Buttons("BtnSelect") .Left = T.Left .Top = T.Top + 10 .Width = 120 .Height = Rows(1).RowHeight End With With .Shapes("chkRecur") .Left = shParam.Buttons("BtnSelect").Left .Top = shParam.Buttons("BtnSelect").Top + shParam.Buttons("BtnSelect").Height + 5 .Height = 25 .Width = 120 End With Set T = Nothing End With 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 ' *.pdf 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.pdf 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 Images" .AllowMultiSelect = False .InitialView = msoFileDialogViewDetails .ButtonName = "Sélection Dossier" .Show If .SelectedItems.Count > 0 Then bRecursif = shParam.CheckBoxes("chkRecur").Value = 1 Application.StatusBar = "" QueryPerformanceCounter Debut TypeFichier(0) = "*.bmp" TypeFichier(1) = "*.emf" TypeFichier(2) = "*.gif" TypeFichier(3) = "*.jfif" TypeFichier(4) = "*.jpe" TypeFichier(5) = "*.jpeg" TypeFichier(6) = "*.jpg" TypeFichier(7) = "*.png" TypeFichier(8) = "*.tif" TypeFichier(9) = "*.tiff" TypeFichier(10) = "*.wmf" DoEvents Cpt = 0 Erase TableauFichiers Rch .SelectedItems(1) If Cpt = 0 Then Application.StatusBar = "Pas de fichiers valides" Exit Sub End If SuppressionDossierPDFsProt CreationDossiers Images2Pdf 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
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 Option Explicit Private Const vbDot = 46 Private Const MAX_PATH As Long = 260 Private Const INVALID_HANDLE_VALUE = -1 Private Const vbBackSlash = "\" Private Const ALL_FILES = "*.*" Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Private Type FILE_PARAMS bRecurse As Boolean bFindOrExclude As Long nCount As Long nSearched As Long sFileNameExt As String sFileRoot As String End Type Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long Private Declare Function FindFirstFile Lib "kernel32" _ Alias "FindFirstFileA" _ (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib "kernel32" _ Alias "FindNextFileA" _ (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long Private Declare Function PathMatchSpec Lib "shlwapi" _ Alias "PathMatchSpecW" _ (ByVal pszFileParam As Long, ByVal pszSpec As Long) As Long Private FP As FILE_PARAMS Private Function MatchSpec(sFile As String, sSpec As String) As Boolean MatchSpec = PathMatchSpec(StrPtr(sFile), StrPtr(sSpec)) = FP.bFindOrExclude End Function Private Function QualifyPath(sPath As String) As String If Right$(sPath, 1) <> vbBackSlash Then QualifyPath = sPath & vbBackSlash Else QualifyPath = sPath End If End Function Sub Rch(sRacine As String) With FP .sFileRoot = QualifyPath(sRacine) .bRecurse = shParam.CheckBoxes("chkRecur").Value = 1 .nCount = 0 .nSearched = 0 .bFindOrExclude = 1 End With SearchForFiles FP.sFileRoot End Sub Private Sub SearchForFiles(sRoot As String) Dim WFD As WIN32_FIND_DATA, i As Long Dim hFile As Long hFile = FindFirstFile(sRoot & ALL_FILES, WFD) If hFile <> INVALID_HANDLE_VALUE Then Do If (WFD.dwFileAttributes And vbDirectory) Then If Asc(WFD.cFileName) <> vbDot Then If FP.bRecurse Then SearchForFiles sRoot & TrimNull(WFD.cFileName) & vbBackSlash End If Else For i = LBound(TypeFichier) To UBound(TypeFichier) If MatchSpec(WFD.cFileName, TypeFichier(i)) Then ReDim Preserve TableauFichiers(Cpt) TableauFichiers(Cpt) = sRoot & TrimNull(WFD.cFileName) Cpt = Cpt + 1 End If Next i End If Application.StatusBar = Cpt & " Fichiers" Loop While FindNextFile(hFile, WFD) End If FindClose hFile End Sub Private Function TrimNull(startStr As String) As String TrimNull = Left$(startStr, lstrlen(StrPtr(startStr))) End Function
PDFCreator Lecture des restrictions de PDFs protégés
Affecter un bouton à la procédure "SelFichier"
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 Option Explicit Private Sub LectureInfos (ByVal sNomfichier As String) Dim sStr As String, pdf As Object, Crypt As Object, sMéthode As String Set pdf = CreateObject("pdfforge.Pdf.Pdf") Set Crypt = CreateObject("pdfforge.PDF.PDFEncryptor") ' Public Function IsEncrypted( _ ' sourceFilename As String _ ' ) As Boolean If pdf.IsEncrypted(sNomfichier) = False Then MsgBox NomFichier(sNomfichier) & " n'est pas crypté", vbInformation + vbOKOnly Exit Sub End If ' Public Function GetEncryptionSettings( _ ' sourceFilename As String, _ ' ownerPassword As String, _ ' ByRef enc As PDFEncryptor _ ' ) As Integer ' Il faut connaitre le mot de passe Propriétaire : ici "master" sStr = pdf.GetEncryptionSettings(sNomfichier, "master", Crypt) sStr = "Paramètres Cryptage de : " & NomFichier(sNomfichier) & vbCrLf sStr = sStr & vbCrLf & "AllowAssembly : " & CStr(Crypt.AllowAssembly) sStr = sStr & vbCrLf & "AllowCopy : " & CStr(Crypt.AllowCopy) sStr = sStr & vbCrLf & "AllowFillIn : " & CStr(Crypt.AllowFillIn) sStr = sStr & vbCrLf & "AllowModifyAnnotations : " & CStr(Crypt.AllowModifyAnnotations) sStr = sStr & vbCrLf & "AllowModifyContents : " & CStr(Crypt.AllowModifyContents) sStr = sStr & vbCrLf & "AllowPrinting : " & CStr(Crypt.AllowPrinting) sStr = sStr & vbCrLf & "AllowPrintingHighResolution : " & CStr(Crypt.AllowPrintingHighResolution) sStr = sStr & vbCrLf & "AllowScreenreaders : " & CStr(Crypt.AllowScreenreaders) ' EncryptionMethod ' 0 RC4 40 Bits ' 1 RC4 128 Bits ' 2 AES 128 Bits Select Case CStr(Crypt.EncryptionMethod) Case 1 sMéthode = "RC4 128 Bits" Case 2 sMéthode = "AES 128 Bits" Case Else sMéthode = "?????" End Select sStr = sStr & vbCrLf & vbCrLf & "Crytage : " & sMéthode Set Crypt = Nothing Set pdf = Nothing MsgBox sStr End Sub Private Function NomFichier(sFichier As String) As String NomFichier = Dir$(sFichier) End Function Sub SelFichier() Dim Fichier As Variant ChDir ThisWorkbook.Path & "\" Fichier = Application.GetOpenFilename("Fichiers PDF (*.Pdf), *.Pdf") If Fichier = False Then Exit Sub DoEvents LectureInfos Fichier End Sub
Acrobat Exécution d'un code JavaScript
L'approche est différente de celle du Post 34
On lit le script en l'affectant à une chaine, puis on exécute cette dernière via ExecuteThisJavaScript.
Créer un bouton et l'affecter à la procédure SelectPDF
Le script appelé est ici : NumPageFooter.js
Numérotation de Pages centrée dans Pied de Page
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 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 sJScript As String Private Sub JScript(ByVal sFichier As String) Dim AcroApp As Object Dim AVDoc As Object Dim AcroForm As Object Dim PDDoc As Object Dim sNomSave As String sNomSave = ThisWorkbook.Path & "\" & "Essai_JS.pdf" Set AcroApp = CreateObject("Acroexch.app") 'AcroApp.Show Set AVDoc = CreateObject("AcroExch.AVDoc") Set AcroForm = CreateObject("AFormAut.App") If AVDoc.Open(sFichier, "") Then AcroForm.Fields.ExecuteThisJavaScript sJScript Set PDDoc = AVDoc.GetPDDoc With PDDoc .Save 1, sNomSave .Close End With Set PDDoc = Nothing AcroApp.CloseAllDocs AcroApp.Exit End If Set AcroForm = Nothing Set AVDoc = Nothing Set AcroApp = Nothing End Sub Private Sub LectureJS(ByVal sFichierJS As String) Dim sChaine As String Dim NumFichier As Integer Close NumFichier = FreeFile sChaine = "" sJScript = "" Open sFichierJS For Input As #NumFichier Do While Not EOF(NumFichier) Line Input #NumFichier, sChaine sJScript = sJScript & sChaine & vbCrLf Loop Close #NumFichier End Sub Sub SelectPDF() Dim Debut As Currency, Fin As Currency, Freq As Currency Dim Fichier As Variant Dim sFichierJS As String ChDir ThisWorkbook.Path & "\" sFichierJS = ThisWorkbook.Path & "\" & "NumPageFooter.js" Fichier = Application.GetOpenFilename("Fichier PDF (*.pdf), *.pdf") If Fichier <> False Then Application.StatusBar = "" QueryPerformanceCounter Debut LectureJS sFichierJS JScript Fichier QueryPerformanceCounter Fin QueryPerformanceFrequency Freq Application.StatusBar = "Terminé : " & Format((Fin - Debut) / Freq, "0.00 s") End If End Sub
Le Script suivant ayant été sauvé sous le nom NumPageFooter.js dans le répertoire de l'application.
Cet autre script (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.
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14 var Box2Width = 100 for (var p = 0; p < this.numPages; p++) { var aRect = this.getPageBox("Crop",p); var TotWidth = aRect[2] - aRect[0] { var bStart=(TotWidth/2)-(Box2Width/2) var bEnd=((TotWidth/2)+(Box2Width/2)) var fp = this.addField(String("xftPage"+p+1), "text", p, [bStart,30,bEnd,15]); fp.value = "Page: " + String(p+1)+ "/" + this.numPages; fp.textSize=10; fp.readonly = true; fp.alignment="center"; } }
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 for (var p = 0; p < this.numPages; p++) { var numWords = this.getPageNumWords(p); for (var i=0; i<numWords; i++) { var ckWord = this.getPageNthWord(p, i, true); if ( ckWord == "Triboulet") {var q = this.getPageNthWordQuads(p, i); m = (new Matrix2D).fromRotated(this,p); mInv = m.invert() r = mInv.transform(q) r=r.toString() r = r.split(","); l = addLink(p, [r[4], r[5], r[2], r[3]]); l.borderColor = color.red l.borderWidth = 1 l.setAction("this.getURL('http://www.adobe.com/');"); } } }
Bonjour kiki29,
J'ai lu et relu les messages, téléchargé les contributions au forum, testés les codes dans ma macro d'impression mais je bloque.
J'ai plusieurs fichiers excel à imprimer en 1 pdf via pdfcreator ;
J'utilise excel 2007.
L'ensemble reste bloqué dans la file d'attente de pdf creator lorsque je dois fusionner les fichiers pour sauvegarde...
Please HELP
Salut, as-tu vu le post 8 : fusion des PDFs d'un dossier via PDFCreator, sinon il y a aussi le post 88, j'oubliais aussi ceci. Il vaut mieux privilégier ceux avec une liste Excel : cela permet, avant de lancer la fusion, de modifier éventuellement l'ordre dans lequel on souhaite fusionner les PDFs. Le tout gratos dans le bazar.
S'il s'agit de feuilles à fusionner en PDF et qu'elles appartiennent au même classeur, il n'y a pas besoin de PDFCreator puisque le format pdf est inclus en natif dans Office depuis le SP2 2007. voir "Impression de certaines Feuilles d'un classeur via un tableau dans un seul Pdf résultant" tout en bas du Post 1.
PS : sinon est-ce que dans PDFCreator.exe ( moniteur d'impression ) le menu Imprimante/Arrêt est décoché ?
Acrobat Reader 11.0.09
Le bug évoqué dans le Post 104 pour les versions 11.0.07 et 11.0.08 a été apparemment résolu dans la version 11.0.09 du Reader.
Pour trouver le Reader 11.0.09 on peut aller ici.
Remarque annexe : le code du Post 21 à l'avantage de supprimer l'apparition du message suivant : Cette application est sur le point d'initialiser des contrôles ActiveX potentiellement non sûrs.
Acrobat Anonymiser les fichiers PDFs d'un dossier ( Effacer les métadonnées )
Créer 5 boutons et une case à cocher sur feuil1.
● Le 1er baptisé btnListe avec intitulé "Liste Fichiers PDF" sera affecté à la procédure Usf du module mRch.
● Le 2eme baptisé btnSelectAll avec intitulé "Tout Sélectionner" sera affecté à la procédure SelectAll du module mPDF.
● Le 3eme baptisé btnUnSelectAll avec intitulé "Tout Désélectionner" sera affecté à la procédure UnSelectAll du module mPDF.
● Le 4eme baptisé btnAnonyme avec intitulé "Anonymiser Fichiers PDF" sera affecté à la procédure AnonymiserPdf du module mPdf.
● Le 5eme baptisé btnEffacer avec intitulé "Effacer" sera affecté à la procédure Effacer du module mRch.
● La case à cocher avec intitulé "Recherche Récursive ?" baptisée chkRecur.
Créer une UserForm avec 2 boutons et une TextBox
● Le 1er bouton avec intitulé "Sélection Dossier Racine" sera affecté à la procédure CommandButton1_Click du code de l'UserForm.
● Le 2eme bouton avec intitulé "Annuler" sera affecté à la procédure CommandButton2_Click du code de l'UserForm.
● La TextBox avec sa propriété value = *.pdf sera baptisée txtBox
Dans ces codes ShDatas est le CodeName de Feuil1 : voir pour explications CodeName.
Code de l'UserForm
Dans module standard baptisé mRch
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 Option Explicit Private Sub CommandButton1_Click() sRch = txtBox.Text If Len(sRch) = 0 Then Me.Hide Exit Sub End If Me.Hide SelDossierRacine End Sub Private Sub CommandButton2_Click() Me.Hide ShDatas.Range("B2").Select End Sub Private Sub UserForm_Initialize() If Len(ShDatas.Range("A2")) = 0 Then ShDatas.Range("A2") = "*.pdf" txtBox.Text = ShDatas.Range("A2") End Sub
Dans module standard baptisé mGlob
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 Option Explicit Private Const vbDot = 46 Private Const MAX_PATH As Long = 260 Private Const INVALID_HANDLE_VALUE = -1 Private Const vbBackSlash = "\" Private Const ALL_FILES = "*.*" Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Private Type FILE_PARAMS bRecurse As Boolean bFindOrExclude As Long nCount As Long nSearched As Long sFileNameExt As String sFileRoot As String End Type Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long Private Declare Function FindFirstFile Lib "kernel32" _ Alias "FindFirstFileA" _ (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib "kernel32" _ Alias "FindNextFileA" _ (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long Private Declare Function PathMatchSpec Lib "shlwapi" _ Alias "PathMatchSpecW" _ (ByVal pszFileParam As Long, ByVal pszSpec As Long) As Long Private FP As FILE_PARAMS Private iNbDossier As Long Sub Effacer() With ShDatas .Activate .Range("A1").ClearContents .Range("A3:A5").ClearContents .Range("A" & RDepart & ":B" & Rows.Count).ClearContents PosBoutons .Range("B2").Select End With End Sub Private Function MatchSpec(sFile As String, sSpec As String) As Boolean MatchSpec = PathMatchSpec(StrPtr(sFile), StrPtr(sSpec)) = FP.bFindOrExclude End Function Private Function QualifyPath(sPath As String) As String If Right$(sPath, 1) <> vbBackSlash Then QualifyPath = sPath & vbBackSlash Else QualifyPath = sPath End If End Function Private Sub Rch(sRacine As String) Dim Debut As Currency, Fin As Currency, Freq As Currency With ShDatas .Columns("A:B").ClearContents .Cells(1, 1) = sRacine .Cells(2, 1) = sRch .Cells(3, 1) = "" .Cells(4, 1) = "" .Cells(5, 1) = "" .Range("B" & RDepart & ":B" & Rows.Count).Clear End With ActiveWindow.ScrollRow = 1 ActiveWindow.ScrollColumn = 1 Application.ScreenUpdating = False With FP .sFileRoot = QualifyPath(ShDatas.Cells(1, 1)) sDossierDepart = FP.sFileRoot iLen = Len(sDossierDepart) .sFileNameExt = ShDatas.Cells(2, 1) .bRecurse = ShDatas.CheckBoxes("chkRecur").Value = 1 .nCount = 0 .nSearched = 0 iNbDossier = 0 ' 0=inclus tous les fichiers ' 1=exclus sauf extension : ici pdf .bFindOrExclude = 1 End With QueryPerformanceCounter Debut SearchForFiles FP.sFileRoot QueryPerformanceCounter Fin QueryPerformanceFrequency Freq With ShDatas .Cells(3, 1) = iNbDossier & " Dossiers" .Cells(4, 1) = Format$(FP.nCount, "###,###,###,##0 Fichiers") .Cells(5, 1) = FormatNumber((Fin - Debut) / Freq, 3) & " s" .Range("A1:A5").HorizontalAlignment = xlLeft .Range("A2:A5").Columns.AutoFit PosBoutons End With Application.ScreenUpdating = True End Sub Private Sub SearchForFiles(sRoot As String) Dim WFD As WIN32_FIND_DATA Dim hFile As Long, sDoss As String hFile = FindFirstFile(sRoot & ALL_FILES, WFD) If hFile <> INVALID_HANDLE_VALUE Then Do If (WFD.dwFileAttributes And vbDirectory) Then If Asc(WFD.cFileName) <> vbDot Then iNbDossier = iNbDossier + 1 If FP.bRecurse Then SearchForFiles sRoot & TrimNull(WFD.cFileName) & vbBackSlash End If Else If MatchSpec(WFD.cFileName, FP.sFileNameExt) Then FP.nCount = FP.nCount + 1 sDoss = Right$(sRoot & TrimNull(WFD.cFileName), Len(sRoot & TrimNull(WFD.cFileName)) - iLen) ShDatas.Cells(FP.nCount + RDepart - 1, 2) = sDoss End If End If Loop While FindNextFile(hFile, WFD) End If DoEvents Application.StatusBar = iNbDossier & " / " & FP.nCount FindClose hFile End Sub Sub SelDossierRacine() Dim sChemin As String sChemin = ThisWorkbook.Path With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = sChemin & "\" .Title = "Sélectionner le Dossier Racine" .AllowMultiSelect = False .InitialView = msoFileDialogViewDetails .ButtonName = "Sélection Dossier" .Show If .SelectedItems.Count > 0 Then ShDatas.Range("B2").Select DoEvents Rch .SelectedItems(1) End If End With End Sub Private Function TrimNull(startStr As String) As String TrimNull = Left$(startStr, lstrlen(StrPtr(startStr))) End Function Sub Usf() UserForm1.Show vbModeless End Sub
Dans module standard baptisé mPDF
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9 Option Explicit Public Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean Public Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean Public sRch As String Public sDossierDepart As String Public Const RDepart = 6 Public iLen As Long
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 Option Explicit Sub AnonymiserPdf() Dim LastRow As Long, i As Long Dim Fichiers() As String Dim sFichier As String Dim Debut As Currency, Fin As Currency, Freq As Currency Dim AcroApp As Object Dim AVDoc As Object Dim PDDoc As Object Dim sInfo As String, iCpt As Long Dim FSO As Object Application.StatusBar = "" QueryPerformanceCounter Debut LastRow = ShDatas.Range("B" & Rows.Count).End(xlUp).Row If LastRow < RDepart Then Exit Sub Erase Fichiers iCpt = 0 Set FSO = CreateObject("Scripting.FileSystemObject") For i = RDepart To LastRow sFichier = ShDatas.Range("A1") & "\" & ShDatas.Range("B" & i) If FSO.fileExists(sFichier) Then If UCase$(ShDatas.Range("A" & i)) = "X" Then ReDim Preserve Fichiers(iCpt) Fichiers(iCpt) = sFichier iCpt = iCpt + 1 End If Else ShDatas.Range("A" & i) = "" End If Next i Set FSO = Nothing If iCpt = 0 Then Exit Sub Set AcroApp = CreateObject("AcroExch.App") Set AVDoc = CreateObject("AcroExch.AVDoc") For i = LBound(Fichiers) To UBound(Fichiers) AVDoc.Open Fichiers(i), "" Set PDDoc = AVDoc.GetPDDoc PDDoc.Open Fichiers(i) sInfo = PDDoc.SetInfo("Title", "") sInfo = PDDoc.SetInfo("Author", "") sInfo = PDDoc.SetInfo("Subject", "") sInfo = PDDoc.SetInfo("Keywords", "") sInfo = PDDoc.SetInfo("Creator", "") sInfo = PDDoc.SetInfo("Producer", "") PDDoc.Save 1, Fichiers(i) PDDoc.Close AVDoc.Close True Application.StatusBar = i + 1 & " / " & UBound(Fichiers) + 1 DoEvents Next i AcroApp.Exit Set PDDoc = Nothing Set AVDoc = Nothing Set AcroApp = Nothing QueryPerformanceCounter Fin QueryPerformanceFrequency Freq Application.StatusBar = Application.StatusBar & " : " & FormatNumber((Fin - Debut) / Freq, 2) & " s" Erase Fichiers PosBoutons ShDatas.Range("B2").Select End Sub Sub PosBoutons(Optional Dummy As String) Dim T As Range With ShDatas .Activate .Rows(1).RowHeight = 12.75 Set T = .Cells(1, 3) With .Buttons("btnListe") .Left = T.Left + 3 .Top = T.Top + ShDatas.Rows(1).RowHeight + 2 .Width = 100 .Height = 2 * Rows(1).RowHeight - 5 End With With .Buttons("btnSelectAll") .Left = ShDatas.Buttons("btnListe").Left + ShDatas.Buttons("btnListe").Width + 5 .Top = ShDatas.Shapes("btnListe").Top .Width = 100 .Height = ShDatas.Buttons("btnListe").Height End With With .Buttons("btnUnSelectAll") .Left = ShDatas.Buttons("btnSelectAll").Left + ShDatas.Buttons("btnSelectAll").Width + 5 .Top = ShDatas.Buttons("btnListe").Top .Width = 100 .Height = ShDatas.Buttons("btnListe").Height End With With .Shapes("chkRecur") .Left = ShDatas.Shapes("btnListe").Left .Top = ShDatas.Shapes("btnListe").Top + ShDatas.Shapes("btnListe").Height + 5 .Width = ShDatas.Buttons("btnListe").Width .Height = ShDatas.Buttons("btnListe").Height End With With .Buttons("btnAnonyme") .Left = ShDatas.Shapes("chkRecur").Left + ShDatas.Shapes("chkRecur").Width + 5 .Top = ShDatas.Shapes("chkRecur").Top + 1 .Width = ShDatas.Buttons("btnListe").Width + 30 .Height = ShDatas.Buttons("btnListe").Height End With With .Buttons("btnEffacer") .Left = ShDatas.Buttons("btnAnonyme").Left + ShDatas.Buttons("btnAnonyme").Width + 25 .Top = ShDatas.Buttons("btnAnonyme").Top .Width = 50 .Height = ShDatas.Buttons("btnAnonyme").Height End With .Range("B2").Select End With End Sub Sub SelectAll() Dim LastRow As Long LastRow = ShDatas.Range("B" & Rows.Count).End(xlUp).Row If LastRow > RDepart Then With ShDatas .Range("A" & RDepart & ":A" & Rows.Count).HorizontalAlignment = xlCenter .Range("A" & RDepart & ":A" & LastRow) = "x" End With End If End Sub Sub UnSelectAll() Dim LastRow As Long LastRow = ShDatas.Range("B" & Rows.Count).End(xlUp).Row If LastRow > RDepart Then With ShDatas .Range("A" & RDepart & ":A" & Rows.Count).HorizontalAlignment = xlCenter .Range("A" & RDepart & ":A" & Rows.Count).ClearContents End With End If End Sub
PDFCreator Anonymiser les fichiers PDFs d'un dossier ( Effacer les métadonnées )
Autrement dit effacer les champs : Titre, Auteur, Sujet, Mots-Clés, Application.
La mise en place est similaire à celle du post 116 ainsi que le code dans les modules mGlob, mRch et UserForm.
Dans module standard baptisé mPDF
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 Option Explicit Dim sCheminTempo As String Const sDossierTempo As String = "~$Tempo$" Sub AnonymiserPdf() Dim LastRow As Long, i As Long Dim Fichiers() As String Dim sFichier As String Dim Debut As Currency, Fin As Currency, Freq As Currency Dim PDF As Object Dim iCpt As Long, iBad As Long Dim FSO As Object, sOut As String Application.StatusBar = "" QueryPerformanceCounter Debut LastRow = ShDatas.Range("B" & Rows.Count).End(xlUp).Row ShDatas.Range("B4").ClearContents If LastRow < RDepart Then Exit Sub CreationDossier Erase Fichiers iCpt = 0 iBad = 0 Set FSO = CreateObject("Scripting.FileSystemObject") For i = RDepart To LastRow sFichier = ShDatas.Range("A1") & "\" & ShDatas.Range("B" & i) If FSO.fileExists(sFichier) Then If UCase$(ShDatas.Range("A" & i)) = "X" Then ReDim Preserve Fichiers(iCpt) Fichiers(iCpt) = sFichier iCpt = iCpt + 1 End If Else ShDatas.Range("A" & i) = "" End If Next i Set FSO = Nothing If iCpt = 0 Then Exit Sub Set PDF = CreateObject("pdfforge.pdf.pdf") Set FSO = CreateObject("Scripting.FileSystemObject") For i = LBound(Fichiers) To UBound(Fichiers) sFichier = FSO.GetFileName(Fichiers(i)) sOut = sCheminTempo & "\" & sFichier On Error GoTo Erreurs ' Public Sub SetMetadata( _ ' sourceFilename As String, _ ' destinationFilename As String, _ ' author As String, _ ' creator As String, _ ' keywords As String, _ ' subject As String, _ ' title As String _ ' ) PDF.SetMetadata Fichiers(i), sOut, "", "", "", "", "" Kill Fichiers(i) Name sOut As Fichiers(i) Retour: Application.StatusBar = i + 1 & " / " & UBound(Fichiers) + 1 DoEvents Next i SuppressionDossier Sortie: Set PDF = Nothing Set FSO = Nothing QueryPerformanceCounter Fin QueryPerformanceFrequency Freq Application.StatusBar = Application.StatusBar & " : " & Format((Fin - Debut) / Freq, "0.00 s") Erase Fichiers PosBoutons ShDatas.Range("B2").Select Exit Sub Erreurs: ' PdfReader not opened with owner password ' Bad user password ' Unable to cast object of type 'iTextSharp.text.pdf.PdfLiteral' to type 'iTextSharp.text.pdf.PdfNumber' If Err.Number = -2147024809 Or Err.Number = -2146232800 Or Err.Number = -2147467262 Then iBad = iBad + 1 With ShDatas .Range("A" & RDepart + i) = "" .Range("B4") = iBad End With Err.Clear Resume Retour Else iBad = iBad + 1 With ShDatas .Range("A" & RDepart + i) = "" .Range("B4") = iBad End With 'Debug.Print Err.Number & vbCrLf & Err.Description MsgBox CStr(RDepart + i) & vbCrLf & Err.Number & vbCrLf & Err.Description Err.Clear Resume Sortie End If End Sub Private Sub CreationDossier() Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") sCheminTempo = ThisWorkbook.Path & "\" & sDossierTempo If Not FSO.FolderExists(sCheminTempo) Then FSO.CreateFolder (sCheminTempo) Set FSO = Nothing End Sub Sub PosBoutons(Optional Dummy As String) Dim T As Range With ShDatas .Activate .Rows(1).RowHeight = 12.75 Set T = .Cells(1, 3) With .Buttons("btnListe") .Left = T.Left + 3 .Top = T.Top + ShDatas.Rows(1).RowHeight + 2 .Width = 100 .Height = 2 * Rows(1).RowHeight - 5 End With With .Buttons("btnSelectAll") .Left = ShDatas.Buttons("btnListe").Left + ShDatas.Buttons("btnListe").Width + 5 .Top = ShDatas.Shapes("btnListe").Top .Width = 100 .Height = ShDatas.Buttons("btnListe").Height End With With .Buttons("btnUnSelectAll") .Left = ShDatas.Buttons("btnSelectAll").Left + ShDatas.Buttons("btnSelectAll").Width + 5 .Top = ShDatas.Buttons("btnListe").Top .Width = 100 .Height = ShDatas.Buttons("btnListe").Height End With With .Shapes("chkRecur") .Left = ShDatas.Shapes("btnListe").Left .Top = ShDatas.Shapes("btnListe").Top + ShDatas.Shapes("btnListe").Height + 5 .Width = ShDatas.Buttons("btnListe").Width .Height = ShDatas.Buttons("btnListe").Height End With With .Buttons("btnAnonyme") .Left = ShDatas.Shapes("chkRecur").Left + ShDatas.Shapes("chkRecur").Width + 5 .Top = ShDatas.Shapes("chkRecur").Top + 1 .Width = ShDatas.Buttons("btnListe").Width + 30 .Height = ShDatas.Buttons("btnListe").Height End With With .Buttons("btnEffacer") .Left = ShDatas.Buttons("btnAnonyme").Left + ShDatas.Buttons("btnAnonyme").Width + 25 .Top = ShDatas.Buttons("btnAnonyme").Top .Width = 50 .Height = ShDatas.Buttons("btnAnonyme").Height End With .Range("B2").Select End With End Sub Sub SelectAll() Dim LastRow As Long LastRow = ShDatas.Range("B" & Rows.Count).End(xlUp).Row If LastRow >= RDepart Then With ShDatas .Range("A" & RDepart & ":A" & Rows.Count).HorizontalAlignment = xlCenter .Range("A" & RDepart & ":A" & LastRow) = "x" End With End If End Sub Sub SuppressionDossier(Optional Dummy As String) Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") sCheminTempo = ThisWorkbook.Path & "\" & sDossierTempo If FSO.FolderExists(sCheminTempo) Then FSO.DeleteFolder (sCheminTempo) Set FSO = Nothing End Sub Sub UnSelectAll() Dim LastRow As Long LastRow = ShDatas.Range("B" & Rows.Count).End(xlUp).Row If LastRow >= RDepart Then With ShDatas .Range("A" & RDepart & ":A" & Rows.Count).HorizontalAlignment = xlCenter .Range("A" & RDepart & ":A" & Rows.Count).ClearContents End With End If End Sub
Acrobat Reader Copier/Coller le texte des PDFs d'un dossier ( recherche récursive ou non ) dans une feuille Excel via Acrobat Reader
voir ici pour l'ensemble du source.
si version 2007+ les modifs à apporter sont notées dans le code de la procédure "Sauvegarde" du module mPdf,
par exemple pour CountLarge
sinon il restera à intégrer à la procédure Pdf2Txt ci-dessous les traitements pour formater les données extraites et cela n'est pas une sinécure.
Tenir compte également de ceci :pour Reader 10 + :
Dans le menu Edition/Préférences catégories : Protection (renforcée)
Décocher "Activer le mode protégé au démarrage".
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 Private Sub Pdf2Txt() Dim sFichier As String Dim sAcro As String Dim LastRow As Long, i As Long, LastRow2 As Long Dim iDep As Long, iFin As Long Dim sDossier As String QueryPerformanceCounter Debut EffacerClipboard DoEvents DecompteA If Cpt = 0 Then MsgBox "Taper dans la colonne A un x ou X en vis à vis" & vbCrLf & _ "des fichiers à traiter de la colonne B", vbInformation + vbOKOnly, "x ou X" Exit Sub End If Application.StatusBar = "" sDossier = ShParam.Cells(1, 1) LastRow = ShParam.Range("B" & Rows.Count).End(xlUp).Row ShExtraction.Activate '========================================================================================================= ' ' L'usage des Sendkeys pose des problèmes à partir du Reader 10 et + ' ' READER : dans son menu Edition/Préférences catégories : Protection(renforcée) ' Décocher "Activer le mode protégé au démarrage" ' '========================================================================================================= ' ' pour XP et le Reader 9.x : sAcro ="C:\Program Files\Adobe\Reader 9.0\Reader\AcroRd32.exe" ' pour Vista et le Reader 10.x : sAcro ="C:\Program Files\Adobe\Reader 10.0\Reader\AcroRd32.exe" ' pour W7 et le Reader 11.x : sAcro ="C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe" ' ' Les valeurs de "Sleep" sont à ajuster en fonction de la configuration ' '========================================================================================================= sAcro = "C:\Program Files\Adobe\Reader 11.0\Reader\AcroRd32.exe" If ExistenceFichier(sAcro) = False Then MsgBox "Le chemin d'Acrobat Reader est erroné : il faudra le corriger manuellement" & vbCrLf & vbCrLf & _ "dans la procédure Pdf2Txt du module mPDF" & vbCrLf & "à sAcro = .....", vbInformation + vbOKOnly, "Chemin du Reader erroné" Debug.Print sAcro Exit Sub End If With ShExtraction .Activate .Cells.Delete Shift:=xlUp .Range("A1").Select End With iDep = 0 iFin = LastRow - RDepart + 1 For i = RDepart To LastRow If UCase$(ShParam.Range("A" & i)) = "X" Then Clavier Sleep 250 iDep = iDep + 1 sFichier = sDossier & "\" & ShParam.Range("B" & i) Shell sAcro & " " & sFichier, vbNormalFocus SendKeys "^a", True SendKeys "^c", True SendKeys "^q", True Sleep 250 LastRow2 = ShExtraction.Range("A" & Rows.Count).End(xlUp).Row If LastRow2 = 1 Then LastRow2 = 0 DoEvents With ShExtraction .Activate .Range("A" & LastRow2 + 1).Select .Paste End With Application.StatusBar = "Extraction : " & iDep & " / " & Cpt End If DoEvents Next i With ActiveWindow .ScrollColumn = 1 .ScrollRow = 1 End With DoEvents With ShExtraction .Activate .Range("B1").Select End With QueryPerformanceCounter Fin QueryPerformanceFrequency Freq Application.StatusBar = "Terminé : " & Format((Fin - Debut) / Freq, "0.00 s") End Sub
Bonjour Philippe,
J'ai bien relu les 3 posts ; auj je n'ai plus le même problème : ma macro fonctionne sans message d'erreur mais je ne retrouve pas le pdf (à partir de pdf creator) enregistré là où il devrait l'être (sous c:\), comme si la macro n'avait rien fait.
Je précise que j'imprime plusieurs onglets de plusieurs classeurs en fonction de certaines conditions.
Merci de votre réponse
Désolée, je ne suis pas très douée en dvp excel...le code envoyé me semble "chinois"
A quel endroit dans la macro dois-je insérer ce code?
J'ai en effet des conditions (If...then) qui me permettent d'ouvrir et d'imprimer 3 classeurs différents avec différentes pages au sein de ces classeur en fonction de mes conditions.
Merci de vos réponses
Vous avez un bloqueur de publicités installé.
Le Club Developpez.com n'affiche que des publicités IT, discrètes et non intrusives.
Afin que nous puissions continuer à vous fournir gratuitement du contenu de qualité, merci de nous soutenir en désactivant votre bloqueur de publicités sur Developpez.com.
Partager