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
| Sub Pdf()
Dim FSO As Object, WshShell As Object, Pdf As Object, i As Long, iLast As Long
Dim sDossier As String, sFichier As String, sNomfichier As String, iNbPages As Long
Dim pdfNumPages As Object, pdfNomFichier As Object, bVide As Boolean, bDoublon As Boolean
Dim sPre As String, sNouveauNom As String, sNomPDF As String
QueryPerformanceCounter Debut
Application.StatusBar = ""
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
bVide = ShParam.CheckBoxes("chkVider").Value = 1
bDoublon = ShParam.CheckBoxes("chkDoublon").Value = 1
sDossier = ThisWorkbook.Path & "\" & "PDFs"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(sDossier) Then
If bVide Then FSO.DeleteFolder sDossier, True
End If
DoEvents
If Not (FSO.FolderExists(sDossier)) Then FSO.CreateFolder sDossier
Set FSO = Nothing
Cpt = 0
iLast = ShParam.Cells(Rows.Count, "B").End(xlUp).Row
For i = RDepart To iLast
If UCase$(ShParam.Range("A" & i)) = "X" Then
Cpt = Cpt + 1
sFichier = ShParam.Cells(1, 1) & "\" & ShParam.Cells(i, 2)
Set FSO = CreateObject("Scripting.FileSystemObject")
sNomfichier = FSO.GetBaseName(sFichier) & ".pdf"
sPre = FSO.GetBaseName(sNomfichier)
Set FSO = Nothing
Set WshShell = CreateObject("WScript.Shell")
Set Pdf = CreateObject("pdfforge.pdf.pdf")
iNbPages = NbPages(sFichier)
If bDoublon Then
sNouveauNom = RenommerFichier(sDossier, sPre & ".pdf")
Else
sNouveauNom = sDossier & "\" & sPre & ".pdf"
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
sNomPDF = FSO.GetFilename(sNouveauNom)
Set FSO = Nothing
Set pdfNumPages = CreateObject("pdfforge.pdf.pdfText")
With pdfNumPages
.Text = "[PAGE] / [PAGES]"
'.Text = "[PAGE]"
.FontColorRed = 0
.FontColorGreen = 0
.FontColorBlue = 0
.FontName = "comic.ttf"
'.FontName = "comicbd.ttf"
.FontPath = WshShell.SpecialFolders("Fonts")
.FontSize = 8
End With
Set pdfNomFichier = CreateObject("pdfforge.pdf.pdfText")
With pdfNomFichier
.Text = sNomPDF
.FontColorRed = 0
.FontColorGreen = 0
.FontColorBlue = 0
.FontName = "comic.ttf"
'.FontName = "timesbd.ttf"
.FontPath = WshShell.SpecialFolders("Fonts")
.FontSize = 8
End With
'Public Function AddPageNumberToPDFFile( _
' sourceFilename As String, _
' destinationFilename As String, _
' fromPage As Integer, _
' toPage As Integer, _
' startPageNumber As Integer, _
' NumberOfPages As Integer, _
' pageNumberPosition As Integer, _
' borderXMillimeter As Single, _
' borderYMillimeter As Single, _
' ByRef textObject As pdfText _
') As Integer
'Page number position
'1: Top Left
'2: Top middle
'3: Top Right
'4: bottom Left
'5: bottom middle
'6: bottom Right
Pdf.AddPageNumberToPDFFile sFichier, sDossier & "\" & "Tempo.pdf", 1, iNbPages, 1, iNbPages, 6, 5, 5, pdfNumPages
Pdf.AddPageNumberToPDFFile sDossier & "\" & "Tempo.pdf", sNouveauNom, 1, iNbPages, 1, iNbPages, 4, 5, 5, pdfNomFichier
Application.StatusBar = Cpt & " / " & iLast - RDepart + 1
Kill sDossier & "\" & "Tempo.pdf"
Set pdfNomFichier = Nothing
Set pdfNumPages = Nothing
Set Pdf = Nothing
Set WshShell = Nothing
End If
Next i
With ShParam
.Activate
.Range("B2").Select
End With
QueryPerformanceCounter Fin
QueryPerformanceFrequency Freq
Application.StatusBar = Application.StatusBar & " / Terminé : " & Format(((Fin - Debut) / Freq), "0.00 s")
End Sub |
Partager