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 |
Partager