1 pièce(s) jointe(s)
Conversion PDF en PS ( PostScript ) via XPDF
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:
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 |
1 pièce(s) jointe(s)
Lecture des métadonnées d'un PDF via XPDF (2)
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 :
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
| 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 |
1 pièce(s) jointe(s)
Liste des Polices d'un PDF via XPDF
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:
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 |
1 pièce(s) jointe(s)
Sauvegarder un PDF au format PDF/A
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
Citation:
%%[ 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 :
Citation:
%%[ 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:
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 |
1 pièce(s) jointe(s)
Sauvegarder un PDF au format PDF/A
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:
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 |
1 pièce(s) jointe(s)
Conversion PDF en PPM via XPDF
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:
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 |
1 pièce(s) jointe(s)
Conversion PDF en PNG via XPDF
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:
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 |
1 pièce(s) jointe(s)
Acrobat : Rognage d'une page d'un PDF
Via Acrobat ( pas le Reader )
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
| 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
1 pièce(s) jointe(s)
Acrobat : Recadrage d'un fichier PDF
Via Acrobat ( pas le Reader )
Suite de ce post, Téléchargeable ici
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
| 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 |
Impression des fichiers PDF d'un dossier
Suite à un post externe à ce forum
Code:
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
1 pièce(s) jointe(s)
Impression de plusieurs plages non contiguës dans un PDF
Ici pour 3 plages nommées Plage_01 à Plage_03.
Code:
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 |
1 pièce(s) jointe(s)
Impression de plusieurs plages non contiguës dans un PDF (2)
Une autre approche avec une fusion via PDFCreator 1.7.3
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
| 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 |
1 pièce(s) jointe(s)
Positionner des pdf sur une feuille Excel
Affecter un bouton à la procédure SelectionPDF
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
| 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
Peupler un formulaire pdf en VB
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
Liens vers les posts sur les Formulaires PDF
liste des fonctions accessibles via les objets "pdfforge.pdf. ???")
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, 8-), 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.:D
Renommer un champ de formulaire
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.
2 pièce(s) jointe(s)
Fusion de Formulaires avec Renommage des Champs
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 ?