PDF avec Adobe Acrobat Pro et PDFCreator 1.7.3 (obsolète)

Version imprimable

Voir 40 message(s) de cette discussion en une page

03/07/2014, 12h22
kiki29

Salut, effectivement il te faut Acrobat Pro ( payant dans les 650 € ), mais qu'importe la version d'Excel.
03/07/2014, 16h32
illight

Même si ta réponse ne me convient pas :mrgreen: je te remercie :P 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 :P
04/07/2014, 22h00
kiki29

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.
12/07/2014, 04h14
kiki29

Acrobat Reader Afficher un PDF dans une UserForm à la page x

Pour le code voir le Post 21

REMARQUE : Ce code se vautre avec le Reader 11.0.07 mais fonctionne avec le Reader 11.0.06
pour trouver le Reader 11.0.06 aller ici.
15/07/2014, 11h00
kiki29

1 pièce(s) jointe(s)

liste des contributions à jour au 15 Juillet 2014

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:

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:

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:

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:

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

Code:

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é mImages2Pdf

Code:

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

Ajouter dans un module standard baptisé mFichiers

Code:

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:

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

Code:

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

Numérotation de Pages centrée dans Pied de Page
Le Script suivant ayant été sauvé sous le nom NumPageFooter.js dans le répertoire de l'application.

Code:

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"; 
        } 
    }

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:

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/');");
			}
		}
}

18/09/2014, 15h36
Fifipro

Code VBA pour impression feuilles excel en pdf via pdfcreator

Citation:

Envoyé par kiki29

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.

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.:ptdr:
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
18/09/2014, 17h14
kiki29

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é ?
19/09/2014, 17h02
kiki29

Afficher un PDF dans une UserForm à la page x

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

Code:

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é mRch

Code:

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é mGlob

Code:

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

Dans module standard baptisé mPDF

Code:

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:

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 :

Citation:

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:

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

06/10/2014, 13h53
Fifipro

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.
06/10/2014, 15h58
Fifipro

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

Voir 40 message(s) de cette discussion en une page