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

**kiki29** · 17/03/2017, 18h41

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

Le pdf sélectionné sera converti dans un dossier par défaut : ici nommé "PS"
Ce dossier est créé, s'il n'existe pas, à la racine de l'appli, les doublons éventuels sont gérés via des indices.

Appli en téléchargement ici

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub PDF2PS(ByVal sFichier)
Dim Wsh As Object, sCheminAppli As String, sDossierPS As String
Dim sNomFichierPS As String, sPre As String, FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sPre = FSO.GetBaseName(sFichier)
    Set FSO = Nothing
 
    sCheminAppli = ThisWorkbook.Path & "\" & "pdftops32.exe"
    sDossierPS = ThisWorkbook.Path & "\" & "PS"
 
    CreationDossier sDossierPS
 
    sNomFichierPS = RenommerFichier(sDossierPS, sPre & ".ps")
 
    Set Wsh = CreateObject("WScript.Shell")
    Wsh.Exec (sCheminAppli & Chr(32) & Chr(34) & sFichier & Chr(34) & " -level3 " & Chr(34) & sNomFichierPS)
    Set Wsh = Nothing
End Sub
 
Private Function RenommerFichier(sDossier As String, sNomfichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sDossier & "\" & sNomfichier) Then
        sNouveauNom = sNomfichier
        sPre = FSO.GetBaseName(sNomfichier)
        sExt = FSO.GetExtensionName(sNomfichier)
 
        i = 0
        While FSO.FileExists(sDossier & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomfichier = sNouveauNom
    End If
    Set FSO = Nothing
 
    RenommerFichier = sDossier & "\" & sNomfichier
End Function
 
Sub SelectionFichier()
Dim FD As FileDialog
 
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "PDF", "*.pdf", 1
        .ButtonName = "Ouvrir fichier"
        .Title = "Sélectionner un fichier PDF"
    End With
 
    If FD.Show = True Then
        DoEvents
        Application.StatusBar = ""
        PDF2PS FD.SelectedItems(1)
    End If
 
    Set FD = Nothing
End Sub

**kiki29** · 20/03/2017, 12h19

En rapport avec ce 1er post
Placer l'utilitaire pdfinfo.exe ( renommé ici en pdfinfo32.exe ) dans le dossier de l'appli.
Cet utilitaire est dans xpdfbin-win-3.04.zip

Le préfixe du pdf sélectionné servira à nommer le fichier généré : ici "Catalogue.pdf" donnera "Catalogue_Infos.txt"

Appli en téléchargement ici

Autres posts sur les métadonnées :

PDFCreator Lecture des métadonnées d'un fichier PDF
PDFCreator Ecriture des métadonnées dans un fichier PDF
Acrobat Lecture des métadonnées d'un fichier PDF
Acrobat Ecriture des métadonnées dans un fichier PDF

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub PDFInfos(ByVal sFichier)
Dim Wsh As Object, FSO As Object, sCheminAppli As String
Dim sPre As String, sOutInfos As String, sDossierInfos As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sPre = FSO.GetBaseName(sFichier)
    Set FSO = Nothing
 
    sDossierInfos = ThisWorkbook.Path & "\" & "INFOS"
    CreationDossier sDossierInfos
 
    sCheminAppli = ThisWorkbook.Path & "\" & "pdfinfo32.exe"
    sOutInfos = sDossierInfos & "\" & sPre & "_Infos.txt"
    Set Wsh = CreateObject("WScript.Shell")
 
    Wsh.Run "cmd  /c  chcp 65001 && " & Chr(34) & sCheminAppli & Chr(34) & Chr(32) _
            & Chr(34) & sFichier & Chr(34) & " > " & Chr(34) & sOutInfos, vbHide, True
 
    Set Wsh = Nothing
End Sub
 
Sub SelectionFichier()
Dim FD As FileDialog
 
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "PDF", "*.pdf", 1
        .ButtonName = "Ouvrir fichier"
        .Title = "Sélectionner un fichier PDF"
    End With
 
    If FD.Show = True Then
        DoEvents
        Application.StatusBar = ""
        PDFInfos FD.SelectedItems(1)
    End If
 
    Set FD = Nothing
End Sub

**kiki29** · 07/04/2017, 02h13

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

Le préfixe du pdf sélectionné servira à nommer le fichier généré : ici "Catalogue.pdf" donnera
"Catalogue_Fonts.txt", les doublons éventuels sont gérés.

Appli en téléchargement ici

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
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
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub PDFFonts(ByVal sFichier)
Dim Wsh As Object, FSO As Object, sCheminAppli As String, sPre As String, sOutFonts As String
Dim sDossierRacine As String, bVide As Boolean
 
    bVide = ShParam.CheckBoxes("chkVider").Value = 1
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sPre = FSO.GetBaseName(sFichier)
    Set FSO = Nothing
 
    sDossierRacine = ThisWorkbook.Path & "\" & "FONTS"
 
    If bVide Then
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If FSO.FolderExists(sDossierRacine) Then FSO.DeleteFolder sDossierRacine, True
        Set FSO = Nothing
    End If
 
    CreationDossier sDossierRacine
 
    sCheminAppli = ThisWorkbook.Path & "\" & "pdffonts32.exe"
    sOutFonts = RenommerFichier(sDossierRacine, sPre & "_Fonts.txt")
 
    Set Wsh = CreateObject("WScript.Shell")
 
    Wsh.Run "cmd  /c  chcp 65001 && " & Chr(34) & sCheminAppli & Chr(34) & Chr(32) _
            & Chr(34) & sFichier & Chr(34) & " > " & Chr(34) & sOutFonts, vbHide, True
 
    Set Wsh = Nothing
End Sub
 
Private Function RenommerFichier(sDossier As String, sNomfichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sDossier & "\" & sNomfichier) Then
        sNouveauNom = sNomfichier
        sPre = FSO.GetBaseName(sNomfichier)
        sExt = FSO.GetExtensionName(sNomfichier)
 
        i = 0
        While FSO.FileExists(sDossier & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomfichier = sNouveauNom
    End If
    Set FSO = Nothing
 
    RenommerFichier = sDossier & "\" & sNomfichier
End Function
 
Sub SelectionFichier()
Dim FD As FileDialog
 
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "PDF", "*.pdf", 1
        .ButtonName = "Ouvrir fichier"
        .Title = "Sélectionner un fichier PDF"
    End With
 
    If FD.Show = True Then
        DoEvents
        Application.StatusBar = ""
        PDFFonts FD.SelectedItems(1)
    End If
 
    Set FD = Nothing
End Sub

**kiki29** · 24/04/2017, 04h09

Sauvegarder un PDF au format PDF/A via Acrobat et Distiller.
A lire : PDF/A-1

Il faut utiliser un Setting d'Acrobat ou en créer un personnalisé et Distiller, pour générer un PS depuis le PDF, et ensuite créer un autre PDF depuis ce PS.
Voir le dossier C:\Program Files (x86)\Adobe\Acrobat 2015\Acrobat\Settings
De base 2 sont fournis : PDFA1b 2005 CMYK.joboptions et PDFA1b 2005 RGB.joboptions dans la version dite Standard, dans la version dite Pro (?).
Cette version dite Pro dispose d'une palette dédiée à ce traitement accessible via Outils/PréPresse.

Pour info : Conversion PDF en PS ( PostScript ) via XPDF
Pour Acrobat voir ici. avec l'option com.adobe.acrobat.ps

Remarque : Il semble que sur certains fichiers le fait d'utiliser Distiller ou xPDF pour générer le fichier PS ( PostScript ) ne produit pas le même log : Distiller créant le PDF/A et xPDF le rejetant.

Echantillons de fichiers *.log générés

Cas d'un fichier accepté

%%[ ProductName: Distiller ]%%
%%[Page: 1]%%
%%[LastPage]%%

<PDFA ISO="19005-1:2005" COMPLIANT="true">

PDF/A Compliance Report

1. Summary

Warnings: The total found in this document was 0.
Violations: The total found in this document was 0.
No problems were found in the document.

This document passes PDF/A-1b:2005 compliance checks.

</PDFA>

Dans le cas inverse d'un rejet qqch du genre :

%%[ Error: Times-Roman not found. Font cannot be embedded. ]%%
%%[ Error: invalidfont; OffendingCommand: findfont ]%%

Stack:
/Font
(Times-Roman)
[/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
.............
/yacute /thorn /ydieresis]
1
1
/F128_0

%%[ Flushing: rest of job (to end-of-file) will be ignored ]%%
%%[ Warning: PostScript error. No PDF file produced. ] %%

Créer un bouton et l'affecter à la procédure SelectionFichier ou alors voir ici

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
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
Option Explicit
 
Private Sub PDF2PS2PDF(sFichier As String)
Dim AcroXApp As Object
Dim AcroXAVDoc As Object
Dim AcroXPDDoc As Object
Dim JSO As Object, FSO As Object
Dim sPre As String
Dim sFichierPS As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sPre = FSO.GetBaseName(sFichier)
    sFichierPS = ThisWorkbook.Path & "\" & sPre & ".ps"
    Set FSO = Nothing
 
    Set AcroXApp = CreateObject("AcroExch.App")
    AcroXApp.Hide
 
    Set AcroXAVDoc = CreateObject("AcroExch.AVDoc")
    AcroXAVDoc.Open sFichier, "Acrobat"
 
    Set AcroXPDDoc = AcroXAVDoc.GetPDDoc
    Set JSO = AcroXPDDoc.GetJSObject
 
    JSO.SaveAs sFichierPS, "com.adobe.acrobat.ps"
 
    AcroXAVDoc.Close False
    AcroXApp.Exit
 
    PS2PDF_Distiller sFichierPS
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sFichierPS) Then FSO.DeleteFile sFichierPS, True
    Set FSO = Nothing
 
    Set JSO = Nothing
    Set AcroXPDDoc = Nothing
    Set AcroXAVDoc = Nothing
    Set AcroXApp = Nothing
End Sub
 
Private Sub PS2PDF_Distiller(sFichierPS As String)
Dim sNomFichierPDF As String
Dim PDFDist As Object
Dim sSetting As String, FSO As Object, sPre As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sPre = FSO.GetBaseName(sFichierPS)
    sNomFichierPDF = ThisWorkbook.Path & "\" & sPre & "_PDFa.pdf"
    Set FSO = Nothing
 
    sSetting = "C:\Program Files (x86)\Adobe\Acrobat 2015\Acrobat\Settings\PDFA1b 2005 RGB.joboptions"
 
    Set PDFDist = CreateObject("PdfDistiller.PdfDistiller")
    PDFDist.FileToPDF sFichierPS, sNomFichierPDF, sSetting
    Set PDFDist = Nothing
End Sub
 
Sub SelectionFichier()
Dim FD As FileDialog
 
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .InitialFileName = ThisWorkbook.Path & "\"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "PDF", "*.pdf", 1
        .ButtonName = "Ouvrir fichier"
        .Title = "Sélectionner un fichier PDF"
    End With
 
    If FD.Show = True Then
        DoEvents
        With Application
            .StatusBar = ""
            .Cursor = xlWait
        End With
 
        PDF2PS2PDF FD.SelectedItems(1)
 
        With Application
            .Cursor = xlDefault
            .StatusBar = "Terminé"
        End With
    End If
 
    Set FD = Nothing
End Sub

**kiki29** · 27/04/2017, 03h45

Sauvegarder un PDF au format PDF/A via XPDF et Distiller.

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

En reprenant le code du post 324 et en tenant compte de la remarque qui y est faite.

Il suffit d'y remplacer Private Sub PDF2PS2PDF(sFichier As String) par Private Sub PDF2PS_XPDF(sFichierPDF As String)
ainsi que dans la Selection de fichier PDF2PS2PDF FD.SelectedItems(1) par PDF2PS_XPDF FD.SelectedItems(1)

Pour le téléchargement voir ici

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Private Sub PDF2PS_XPDF(sFichierPDF As String)
Dim Wsh As Object, sCheminAppli As String
Dim sNomFichierPS As String, sPre As String, FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sPre = FSO.GetBaseName(sFichierPDF)
    Set FSO = Nothing
 
    sCheminAppli = ThisWorkbook.Path & "\" & "pdftops32.exe"
 
    sNomFichierPS = ThisWorkbook.Path & "\" & sPre & ".ps"
 
    Set Wsh = CreateObject("WScript.Shell")
 
    Wsh.Run "cmd  /c  chcp 65001 && " & Chr(34) & sCheminAppli & Chr(34) & Chr(32) _
            & Chr(34) & sFichierPDF & Chr(34) & " -level3 " & Chr(34) & sNomFichierPS, vbHide, True
    Set Wsh = Nothing
 
    PS2PDF_Distiller sNomFichierPS
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sNomFichierPS) Then FSO.DeleteFile sNomFichierPS, True
    Set FSO = Nothing
End Sub

**kiki29** · 03/05/2017, 04h38

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

Le pdf sélectionné sera converti dans un dossier par défaut : ici nommé "PPM"
Ce dossier est créé, s'il n'existe pas, à la racine de l'appli. Les doublons éventuels sont gérés.

Appli en téléchargement ici

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
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
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub PDF2Ppm(ByVal sFichier)
Dim Wsh As Object, sCheminAppli As String, sDossierImages As String
Dim sPre As String, FSO As Object, sNomImages As String
Dim sDossierRacine As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sPre = FSO.GetBaseName(sFichier)
    Set FSO = Nothing
 
    sCheminAppli = ThisWorkbook.Path & "\" & "pdftoppm32.exe"
 
    sDossierRacine = ThisWorkbook.Path & "\" & "PPM"
    CreationDossier sDossierRacine
 
    sDossierImages = RenommerDossier(sDossierRacine, sPre)
    sNomImages = sDossierImages & "\" & sPre
 
    Set Wsh = CreateObject("WScript.Shell")
 
    Wsh.Run "cmd  /c  chcp 65001 && " & Chr(34) & sCheminAppli & Chr(34) & Chr(32) _
            & Chr(34) & sFichier & Chr(34) & " -aa yes -r 72 -aaVector yes " _
            & Chr(34) & sNomImages, vbHide, True
    Set Wsh = Nothing
End Sub
 
Private Function RenommerDossier(ByVal sChemin As String, ByVal sDossier As String) As String
Dim sNouveauNom As String, sNomDossier As String
Dim i As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(sChemin & "\" & sDossier) Then
        sNouveauNom = sDossier
        i = 0
        While FSO.FolderExists(sChemin & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sDossier & Chr(40) & Format(i, "000") & Chr(41)
        Wend
        sNomDossier = sNouveauNom
    Else
        sNomDossier = sDossier
    End If
    Set FSO = Nothing
 
    CreationDossier sChemin & "\" & sNomDossier
    RenommerDossier = sChemin & "\" & sNomDossier
End Function
 
Sub SelectionFichier()
Dim FD As FileDialog
 
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "PDF", "*.pdf", 1
        .ButtonName = "Ouvrir fichier"
        .Title = "Sélectionner un fichier PDF"
    End With
 
    If FD.Show = True Then
        DoEvents
        Application.StatusBar = ""
        PDF2Ppm FD.SelectedItems(1)
    End If
 
    Set FD = Nothing
End Sub

**kiki29** · 16/05/2017, 00h32

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

Le pdf sélectionné sera converti dans un dossier par défaut : ici nommé "PNG"
Ce dossier est créé, s'il n'existe pas à la racine de l'appli, les doublons éventuels sont gérés.

Appli en téléchargement ici

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub PDF2Png(ByVal sFichier)
Dim Wsh As Object, sCheminAppli As String, sDossierRacine As String
Dim sNomFichierPS As String, sPre As String, FSO As Object, sNomImages As String
Dim sDossierImages As String, bVide As Boolean
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sPre = FSO.GetBaseName(sFichier)
    Set FSO = Nothing
 
    sCheminAppli = ThisWorkbook.Path & "\" & "pdftopng32.exe"
    sDossierRacine = ThisWorkbook.Path & "\" & "PNG"
 
    CreationDossier sDossierRacine
 
    sDossierImages = RenommerDossier(sDossierRacine, sPre)
    sNomImages = sDossierImages & "\" & sPre
 
    Set Wsh = CreateObject("WScript.Shell")
 
    Wsh.Run "cmd  /c  chcp 65001 && " & Chr(34) & sCheminAppli & Chr(34) & Chr(32) _
            & Chr(34) & sFichier & Chr(34) & " -aa yes -r 72 -aaVector yes " _
            & Chr(34) & sNomImages, vbHide, True
    Set Wsh = Nothing
End Sub
 
Private Function RenommerDossier(ByVal sChemin As String, ByVal sDossier As String) As String
Dim sNouveauNom As String, sNomDossier As String
Dim i As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(sChemin & "\" & sDossier) Then
        sNouveauNom = sDossier
        i = 0
        While FSO.FolderExists(sChemin & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sDossier & Chr(40) & Format(i, "000") & Chr(41)
        Wend
        sNomDossier = sNouveauNom
    Else
        sNomDossier = sDossier
    End If
    Set FSO = Nothing
 
    CreationDossier sChemin & "\" & sNomDossier
    RenommerDossier = sChemin & "\" & sNomDossier
End Function

**kiki29** · 01/06/2017, 03h12

Via Acrobat ( pas le Reader )

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
Option Explicit
 
Private Sub Crop_PageX_PDF(ByVal sFichier As String)
Dim PDDoc As Object
Dim AcroRect As Object
Dim JSO As Object, Page As Object
Dim FSO As Object, sNom As String, iNbPages As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sNom = FSO.GetBaseName(sFichier)
    Set FSO = Nothing
 
    Set PDDoc = CreateObject("AcroExch.PDDoc")
    Set AcroRect = CreateObject("AcroExch.Rect")
 
    iNumPage = 1
 
    If PDDoc.Open(sFichier) Then
        Set JSO = PDDoc.GetJSObject
        Set Page = PDDoc.AcquirePage(iNumPage - 1)
        iNbPages = PDDoc.GetNumPages()
 
        AcroRect.Left = 0.5 * 72
        AcroRect.Top = 4 * 72
        AcroRect.bottom = 1 * 72
        AcroRect.Right = 6.75 * 72
 
        Page.CropPage AcroRect
        JSO.ExtractPages iNumPage - 1, iNumPage - 1, ThisWorkbook.Path & "\" & sNom & "_Crop.pdf"
    End If
    PDDoc.Close
 
    Set Page = Nothing
    Set JSO = Nothing
    Set AcroRect = Nothing
    Set PDDoc = Nothing
 
    Application.StatusBar = "Terminé"
End Sub
 
Sub SelFichierPDF()
Dim Fichier As Variant
    ChDir ThisWorkbook.Path
    Fichier = Application.GetOpenFilename("Fichiers PDF (*.pdf), *.pdf")
    If Fichier = False Then Exit Sub
    DoEvents
    Crop_PageX_PDF Fichier
End Sub

Téléchargeable ici

**kiki29** · 18/06/2017, 07h27

Via Acrobat ( pas le Reader )

Suite de ce post, Téléchargeable ici

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
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
Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Dim Debut As Currency, Fin As Currency, Freq As Currency
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub Crop_Pages_PDF(ByVal sFichier As String)
Dim PDDoc As Object
Dim AcroRect As Object
Dim JSO As Object, Page As Object
Dim FSO As Object, sNom As String, iNbPages As Long
Dim sNumPage As String, i As Long, bVide As Boolean
Dim sDossierCrop As String, sOutPDF As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sNom = FSO.GetBaseName(sFichier)
    Set FSO = Nothing
 
    sDossierCrop = ThisWorkbook.Path & "\" & "CROP"
    bVide = ShParam.CheckBoxes("chkVider").Value = 1
    If bVide Then
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If FSO.FolderExists(sDossierCrop) Then FSO.DeleteFolder sDossierCrop, True
        Set FSO = Nothing
    End If
 
    CreationDossier sDossierCrop
 
    Set PDDoc = CreateObject("AcroExch.PDDoc")
    Set AcroRect = CreateObject("AcroExch.Rect")
 
    If PDDoc.Open(sFichier) Then
        Set JSO = PDDoc.GetJSObject
        iNbPages = PDDoc.GetNumPages()
 
        For i = 1 To iNbPages
            Set Page = PDDoc.AcquirePage(i - 1)
 
            sNumPage = Format(i, "000")
            sOutPDF = RenommerFichier(sDossierCrop, sNom & "_" & sNumPage & ".pdf")
 
            AcroRect.Left = 0.5 * 72
            AcroRect.Top = 4 * 72
            AcroRect.bottom = 1 * 72
            AcroRect.Right = 6.75 * 72
 
            Page.CropPage AcroRect
            JSO.ExtractPages i - 1, i - 1, sOutPDF
            Application.StatusBar = i & " / " & iNbPages
        Next i
    End If
    PDDoc.Close
 
    Set Page = Nothing
    Set JSO = Nothing
    Set AcroRect = Nothing
    Set PDDoc = Nothing
 
    With ShParam
        .Activate
        .Range("A1").Select
    End With
 
    Application.StatusBar = Application.StatusBar & " / Terminé"
End Sub
 
Private Sub PosBoutons()
Dim T As Range
    With ShParam
        .Activate
        .Rows(1).RowHeight = 12.75
 
        Set T = .Cells(1, 2)
        With .Buttons("btnFichier")
            .Left = T.Left + 3
            .Top = T.Top + 15
            .Width = 110
            .Height = 2 * Rows(1).RowHeight - 5
        End With
 
        With .Shapes("chkVider")
            .Left = ShParam.Shapes("btnFichier").Left + ShParam.Shapes("btnFichier").Width + 5
            .Top = ShParam.Shapes("btnFichier").Top
            .Width = 160
            .Height = ShParam.Buttons("btnFichier").Height
        End With
 
        .Range("A1").Select
    End With
End Sub
 
Private Function RenommerFichier(sDossier As String, sNomfichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sDossier & "\" & sNomfichier) Then
        sNouveauNom = sNomfichier
        sPre = FSO.GetBaseName(sNomfichier)
        sExt = FSO.GetExtensionName(sNomfichier)
 
        i = 0
        While FSO.FileExists(sDossier & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomfichier = sNouveauNom
    End If
    Set FSO = Nothing
 
    RenommerFichier = sDossier & "\" & sNomfichier
End Function
 
Sub SelFichierPDF()
Dim Fichier As Variant
    ChDir ThisWorkbook.Path
    Fichier = Application.GetOpenFilename("Fichiers PDF (*.pdf), *.pdf")
    If Fichier = False Then Exit Sub
    DoEvents
    With Application
        .StatusBar = ""
        .Cursor = xlWait
    End With
    QueryPerformanceCounter Debut
 
    Crop_Pages_PDF Fichier
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    With Application
        .StatusBar = .StatusBar & " / " & Format((Fin - Debut) / Freq, "0.00 s")
        .Cursor = xlDefault
    End With
End Sub

**kiki29** · 08/07/2017, 00h03

Suite à un post externe à ce forum

Prendre ce fichier : Liste des fichiers d'un dossier
Y insérer une procédure baptisée "Impression"

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Sub Impression()
Dim sChemin As String
Dim hwnd As Long, i As Long
Dim LastRow As Long
    LastRow = ShParam.Range("B" & Rows.Count).End(xlUp).Row
    If LastRow < RDepart Then Exit Sub
    For i = RDepart To LastRow
        sChemin = ShParam.Range("A1") & "\" & ShParam.Range("B" & i)
        ShellExecute hwnd, "Print", sChemin, "", "", 1
        Application.StatusBar = i - RDepart + 1
    Next i
End Sub

Affecter un bouton "Impression Fichiers" baptisé btnPrint à cette procédure

Téléchargeable ici

**kiki29** · 31/07/2017, 09h19

Ici pour 3 plages nommées Plage_01 à Plage_03.

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Option Explicit
 
Sub Tst()
Dim Rg As Range
    Set Rg = Application.Union(Range("Plage_01"), Range("Plage_02"), Range("Plage_03"))
    Rg.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                           ThisWorkbook.Path & "\" & "Test.pdf", _
                           Quality:=xlQualityStandard, _
                           IncludeDocProperties:=True, _
                           IgnorePrintAreas:=False, _
                           OpenAfterPublish:=False
    Set Rg = Nothing
End Sub

**kiki29** · 02/08/2017, 09h28

Une autre approche avec une fusion via PDFCreator 1.7.3

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
Option Explicit
 
Sub Test()
    Feuil1.PageSetup.PrintArea = "$A$1:$F$30"
 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                                    ThisWorkbook.Path & "\" & "1.pdf", _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False
 
    Feuil1.PageSetup.PrintArea = "$H$18:$N$49"
 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                                    ThisWorkbook.Path & "\" & "2.pdf", _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False
 
    Feuil1.PageSetup.PrintArea = "$Q$39:$X$58"
 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                                    ThisWorkbook.Path & "\" & "3.pdf", _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False
    Fusion
End Sub
 
Private Sub Fusion()
Dim Pdf As Object, Fichiers(2) As Variant
 
    Set Pdf = CreateObject("pdfforge.pdf.pdf")
 
    Fichiers(0) = ThisWorkbook.Path & "\" & "1.pdf"
    Fichiers(1) = ThisWorkbook.Path & "\" & "2.pdf"
    Fichiers(2) = ThisWorkbook.Path & "\" & "3.pdf"
 
    Pdf.MergePDFFiles_2 Fichiers, ThisWorkbook.Path & "\" & "Fusion.pdf", True
 
    Kill Fichiers(0)
    Kill Fichiers(1)
    Kill Fichiers(2)
 
    Set Pdf = Nothing
End Sub

**kiki29** · 07/09/2017, 04h45

Affecter un bouton à la procédure SelectionPDF

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
Option Explicit
 
Private Function ExistenceFichier(sFichier As String) As Boolean
    ExistenceFichier = Dir$(sFichier) <> ""
End Function
 
Sub SelectionPDF()
Dim OLEobj As OLEObject
Dim Gauche As Double, Haut As Double, Largeur As Double, Hauteur As Double
Dim sFichier As String, sCheminReader As String, sCheminRacine As String
 
    sCheminReader = LocaliserAcroReader
    sCheminRacine = ThisWorkbook.Path & "\"
 
    If ExistenceFichier(sCheminReader) = False Then
        MsgBox "Le chemin d'Acrobat Reader est erroné ou" & vbCrLf & "Acrobat Reader n'est pas installé", _
               vbInformation + vbOKOnly, "Chemin du Reader"
        Exit Sub
    End If
 
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = sCheminRacine
        .Title = "Sélectionner le fichier PDF"
        .AllowMultiSelect = False
        .ButtonName = "Sélection Fichier"
        With .Filters
            .Clear
            .Add "PDF", "*.pdf"
        End With
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            Application.ScreenUpdating = False
 
            Gauche = ActiveCell.Left
            Haut = ActiveCell.Top
            Largeur = ActiveCell.Width * 3
            Hauteur = ActiveCell.Height * 8
 
            sFichier = .SelectedItems(1)
 
            Set OLEobj = ActiveSheet.OLEObjects.Add(Filename:=sFichier)
 
            With OLEobj
                .Left = Gauche
                .Top = Haut
                .Width = Largeur
                .Height = Hauteur
            End With
 
            Application.ScreenUpdating = True
            Set OLEobj = Nothing
        End If
    End With
End Sub
 
Private Function LocaliserAcroReader() As String
Dim FSO As Object
Dim Wsh As Object
Dim sCheminReader As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Wsh = CreateObject("WScript.Shell")
 
    sCheminReader = Wsh.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\AcroRd32.exe\")
 
    If Not IsNull(FSO.GetAbsolutePathName(sCheminReader)) Then
        LocaliserAcroReader = FSO.GetAbsolutePathName(sCheminReader)
    Else
        LocaliserAcroReader = ""
    End If
 
    Set Wsh = Nothing
    Set FSO = Nothing
End Function

Téléchargeable ici

**elgordopresto** · 22/09/2017, 16h10

Bonjour Kiki29,

Tout d'abord, chapeau pour ce fil de discussion, la quantité d'idées et de bouts de codes fort utiles et tout simplement prodigieuse.

J'ai un problème que j'ai soumis dans le forum Access ici.

Dans ma société, les commerciaux utilisent massivement des formulaires PDF qui contiennent souvent des champs redondants (nom, prénom du client, ID, etc...). Ils y sont obligés car selon le contexte, la liste des formulaires à produire est différente. Mon idée était donc de préremplir ces formulaires en leur faisant saisir une seule fois les données récurrentes via un formulaire access puis, via une procédure vb, disséminer l'information dans tous les documents nécessaires.

J'ai utilisé pour cela le code que tu mets à disposition dans ton post #42. Je dispose de la version payante d'acrobat mais malheureusement ce n'est pas le cas de nos commerciaux.

J'essaie de trouver des solutions alternatives en cherchant sur le web, mais pour l'heure, sans succès...

C'est pour cela que je me tourne vers toi aussi, si tu as un peu de temps, peux tu me confirmer s'il est possible de préremplir des PDF avec PDFCreator (ce logiciel est installé sur tous les postes chez nous) ?

Par ailleurs, tu précises à plusieurs reprises dans tes différents posts que les procédures documentées ici ne fonctionnent que pour la version payante d'Acrobat. Cela signifie-t-il qu'il y a une limitation structurelle d'Acrobat Reader et que ce dernier ne permet pas l'automation (via vb ou d'autres moyens) ?

Je te remercie par avance pour ton aide et reste à ta disposition si tu as besoin d'informations complémentaires.

Bien cordialement.
el

**kiki29** · 23/09/2017, 01h40

Salut,
Merci pour ton appréciation sur cette contribution. Il y a cette Liste des contributions et téléchargements qui permet à priori de naviguer dans le bazar.

Hors Acrobat ( pas le Reader ) point de salut, PDFCreator ne permet pas de remplir des formulaires PDF.

Il y a une méthode "acrobatique" dont je parle ici : Remplissage de formulaire PDF

L'on retrouve un exemple de cette méthode donnée par son auteur ici
Cela demande à être adapté pour chacun des formulaires.

**kiki29** · 25/09/2017, 10h26

Si cela peut aider :

Acrobatique : Remplissage de formulaire PDF qui renvoie ici

**F_Gressier** · 26/09/2017, 22h57

Bonjour,

Je programme pas mal en VBA et je vois qu'il y a souvent dans tes posts du "CreateObject("pdfforge.pdf.pdf") " ou similaire.
A part tes bouts de code (dont je me sert pour faire du splits et du merge,

, je ne trouve pas de doc sur ces objets, leur fonctions, leur paramètres ...

via l'explorateur d'objet de l'éditeur VBA, je vois dans la bibliothèque "Pdf Creator_com" pas mal de choses mais rien de tel que du "MergePDFFiles_2" etc...

J'ai récupéré ta table des contributions de ce post et elle me sera très utile mais, existe t'il une doc qui liste toute les fonctions accessibles cela (en anglais ce ne serait pas un pb.)

Je vois que tu mets en commentaire la liste des arguments des fonctions que tu utilise dans chaque post:

par exemple:

'Public Sub EmbedFilesInPDFFile ( _
' sourceFilename As String, _
' destinationFilename As String, _
' ByRef embedFilenames As Object(), _
' compress As Boolean _
')

Si la liste complète de tout cela existe, ce serait super.

Encore merci pour tout les sujets traités et
Par avance merci pour ta réponse.

**kiki29** · 27/09/2017, 10h00

Salut, pour la 1.x ( et précédentes ) dans mon cas c'était juste de la curiosité, rien que de la curiosité et en 2011 leur site/forums.
Depuis la version 2.x tout a changé, méthodes/propriétés ne sont plus accessibles, exemples absents etc car versions payantes à vendre ...
Pour Acrobat tu trouveras de la doc ( 2000 pages environ ) sur leur site.

**Xonic** · 01/10/2017, 16h39

Bonjour,

C'est vraiment un excellent travail que vous proposez ici.

En m'inspirant des différents posts,

je peux remplir les différents champs de formulaire, mais si je veux fusionner plusieurs pdf créés avec le même formulaire de base, tous les champs ayant le même nom, ils ont tous la même valeur.

Il faudrait pouvoir renommer les champs mais je ne trouve pas comment faire.

Exemple:
fichier 1.pdf avec le champ Text1.Value = essai1
fichier 2.pdf avec le champ Text1.Value = essai2

Quand je veux fusionner ces 2 pdf en un seul, le champ ayant le même nom, ils ont alors tous la même valeur (essai1)

Comment renommer le champ afin de pouvoir fusionner sans problème.

**kiki29** · 01/10/2017, 19h51

Salut,
Merci pour ton appréciation sur cette contribution. A ce jour toutes mes recherches sont restées vaines.
Acrobat / Création et personnalisation d’un porte-documents PDF

S'il s'agit d'archiver des résultats peut-être que Acrobat Pro Lecture de Formulaires PDF est suffisant ?
On pourra s'inspirer de Conversion d'un dossier Images en PDFs protégés par mots de passe via PDFCreator pour sauvegarder la feuille d'extraction des résultats en PDF avec mot de passe ?

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

Contribuez

Discussions similaires

Partager

Partager