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
| Option Explicit
'Compression des images de documents Word contenus dans un répertoire et des sous répertoires de manière récursive (Aurélien GUYOT 02/2019)
'Testé avec Excel 16
'Activer les références Microsoft Scripting RunTime, Microsoft Word X.X Object Library
'Sources:
'https://www.excelforum.com/excel-programming-vba-macros/937331-picture-compression-macro-2013-a.html
'https://www.experts-exchange.com/questions/24033386/VBA-Word-Automation-SendKeys-Alternative.html
'https://www.developpez.net/forums/d200523/logiciels/microsoft-office/excel/contribuez/lister-fichiers-d-repertoire-feuille-excel/
Private Sub Compresserlesimages()
'Définir le répertoire contenant les documents
ListFilesInFolder "C:\Users\Aurel\Desktop\DocsWord", True
End Sub
Sub ListFilesInFolder(strFolderName As String, bIncludeSubfolders As Boolean)
Static FSO As FileSystemObject
Dim oSourceFolder As Scripting.Folder
Dim oSubFolder As Scripting.Folder
Dim ofile As Scripting.file
Static wksDest As Worksheet
Static iRow As Long
Static bNotFirstTime As Boolean
Dim preminstance As Long
preminstance = iRow + 1
Static appliWord As Word.Application
Dim docWord As Word.Document
If Not bNotFirstTime Then
Set wksDest = ActiveSheet
Set FSO = CreateObject("Scripting.FileSystemObject")
'Exécution d'une instance Word
Set appliWord = CreateObject("Word.Application")
appliWord.Visible = True
'Création du tableau récapitulatif des fichiers modifiés
With wksDest
.Cells.Clear
.Cells(1, 1) = "Fichier"
.Cells(1, 2) = "Taille"
.Cells(1, 3) = "Taille après compression"
End With
iRow = 2
bNotFirstTime = True
End If
Set oSourceFolder = FSO.GetFolder(strFolderName)
For Each ofile In oSourceFolder.Files
'Sélection des documents .doc et .docx à l'exception des fichiers temporaires
If ofile.Name Like "[!~$]*.doc*" Then
With wksDest
.Cells(iRow, 1) = ofile.Path
.Cells(iRow, 2) = ofile.Size
End With
'Compresion des images dans le documents Word ouvert
With appliWord
Set docWord = .Documents.Open(ofile.Path)
AppActivate ofile.Name
'Résolution de l'image: P = Impression (200ppp) ; W = Web(150ppp)
SendKeys "%A%P{Enter}"
'SendKeys "%A%W{Enter}"
.CommandBars.ExecuteMso "PicturesCompress"
'Sauvegard et fermeture du document Word
.ActiveDocument.Save
.ActiveDocument.Close
With wksDest
.Cells(iRow, 3) = ofile.Size
End With
End With
iRow = iRow + 1
End If
Next ofile
'Exécution du script dans les sous-dossiers de manière récursive
If bIncludeSubfolders Then
For Each oSubFolder In oSourceFolder.SubFolders
ListFilesInFolder oSubFolder.Path, True
Next oSubFolder
End If
'Fin, retour à l'instance initiale du script
If preminstance = 1 Then
Set docWord = Nothing
appliWord.Quit
Set appliWord = Nothing
Dim taille1 As Long, taille2 As Long, gain As Long
With wksDest
taille1 = Application.WorksheetFunction.Sum(.Range("B2:B" & iRow - 1))
taille2 = Application.WorksheetFunction.Sum(.Range("C2:C" & iRow - 1))
gain = taille1 - taille2
taille1 = Round(taille1 / 1024 ^ 2, 1)
taille2 = Round(taille2 / 1024 ^ 2, 1)
gain = Round(gain / 1024 ^ 2, 1)
'Affichage du résultat
MsgBox "Nombre de Fichiers traités: " & iRow - 2 & vbCrLf _
& "Taille des fichiers avant compression:" & taille1 & "Mio" & vbCrLf _
& "Taille des fichiers après compression:" & taille2 & "Mio" & vbCrLf _
& "Gain:" & gain & "Mio", _
vbOKOnly, "Compression terminée"
End With
Set FSO = Nothing
Set oSourceFolder = Nothing
Set oSubFolder = Nothing
Set ofile = Nothing
Set wksDest = Nothing
iRow = 0
bNotFirstTime = False
strFolderName = ""
End If
End Sub |
Compression des images contenues dans tous les documents Word d'un répertoire à partir d'Excel
Répondre avec citation
Partager