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
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
| Sub Clean_FR()
Dim sld As slide, shp As shape, lay As CustomLayout
Dim totalModifs As Long: totalModifs = 0
Dim selectedShape As shape
' Vérifier si une sélection est active
On Error Resume Next ' Ignorer les erreurs si rien n'est sélectionné
Set selectedShape = ActiveWindow.Selection.ShapeRange(1)
On Error GoTo 0 ' Réactiver la gestion des erreurs
If Not selectedShape Is Nothing Then
' Si une forme est sélectionnée, appliquer la macro uniquement sur cette forme
totalModifs = CleanTextEmpirique(selectedShape)
Else
' Sinon, appliquer la macro sur toutes les diapositives
' Slides + Notes
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
totalModifs = totalModifs + CleanTextEmpirique(shp)
Next shp
For Each shp In sld.NotesPage.Shapes
totalModifs = totalModifs + CleanTextEmpirique(shp)
Next shp
Next sld
' Masque principal
For Each shp In ActivePresentation.slideMaster.Shapes
totalModifs = totalModifs + CleanTextEmpirique(shp)
Next shp
' Layouts
For Each lay In ActivePresentation.slideMaster.CustomLayouts
For Each shp In lay.Shapes
totalModifs = totalModifs + CleanTextEmpirique(shp)
Next shp
Next lay
End If
' Afficher un message avec le nombre de modifications
MsgBox totalModifs & " modification(s) effectuée(s).", vbInformation, "Nettoyage typographique"
' Appliquer la langue française à tous les éléments après nettoyage
ChangerLangueEnFrancais
End Sub
Private Function CleanTextEmpirique(shp As shape) As Long
Dim i As Long, modifs As Long: modifs = 0
On Error Resume Next
If shp.Type = msoGroup Then
For i = 1 To shp.GroupItems.count
modifs = modifs + CleanTextEmpirique(shp.GroupItems(i))
Next i
ElseIf shp.Type = msoTable Then
modifs = modifs + CleanTableText(shp)
ElseIf shp.HasTextFrame Then
If shp.TextFrame.HasText Then
modifs = modifs + CleanTextRange(shp.TextFrame.TextRange)
End If
End If
CleanTextEmpirique = modifs
End Function
Private Function CleanTableText(tblShp As shape) As Long
Dim r As Long, c As Long, modifs As Long: modifs = 0
For r = 1 To tblShp.Table.Rows.count
For c = 1 To tblShp.Table.Columns.count
With tblShp.Table.cell(r, c).shape.TextFrame
If .HasText Then
modifs = modifs + CleanTextRange(.TextRange)
End If
End With
Next c
Next r
CleanTableText = modifs
End Function
Private Function CleanTextRange(tr As TextRange) As Long
Dim txt As String, i As Long, fineInsec As String: fineInsec = ChrW(&H202F)
Dim oldTxt As String, n As Long, modifs As Long: modifs = 0
txt = tr.text
oldTxt = txt
' Nettoyage
txt = Replace(txt, " ,", ",")
txt = Replace(txt, " .", ".")
txt = Replace(txt, "http://", "__PROTECTED_HTTP__")
txt = Replace(txt, "https://", "__PROTECTED_HTTPS__")
txt = RegReplace(txt, "\s*/\s*", " / ")
txt = RegReplace(txt, "\s*:\s*", " : ")
txt = Replace(txt, "__PROTECTED_HTTP__", "http://")
txt = Replace(txt, "__PROTECTED_HTTPS__", "https://")
txt = RegReplace(txt, "(\d)(%|€)", "$1" & fineInsec & "$2")
' Changer la première lettre après les deux-points et un espace en minuscule
Dim pos As Long
pos = InStr(txt, ": ") ' Cherche l'occurrence de ": " dans le texte
Do While pos > 0
' Si une majuscule suit ": ", on la transforme en minuscule
If Mid(txt, pos + 2, 1) Like "[A-Z]" Then
txt = Left(txt, pos + 1) & LCase(Mid(txt, pos + 2, 1)) & Mid(txt, pos + 3)
End If
' Cherche le prochain ": " dans le texte
pos = InStr(pos + 1, txt, ": ")
Loop
' Remplacer les guillemets anglais (typographiques) par les guillemets français
txt = Replace(txt, "“", "«") ' Remplacer guillemet ouvrant typographique par guillemet français
txt = Replace(txt, "”", "»") ' Remplacer guillemet fermant typographique par guillemet français
' Remplacement des formules chimiques, etc.
txt = Replace(txt, "CO2", "CO" & ChrW(8322))
txt = Replace(txt, "co2", "CO" & ChrW(8322))
txt = Replace(txt, "Co2", "CO" & ChrW(8322))
txt = Replace(txt, "H2O", "H" & ChrW(8322) & "O")
txt = Replace(txt, "h2o", "H" & ChrW(8322) & "O")
txt = Replace(txt, "H2o", "H" & ChrW(8322) & "O")
txt = Replace(txt, "m2", "m²")
txt = Replace(txt, "m3", "m³")
txt = Replace(txt, "cm2", "m²")
txt = Replace(txt, "M2", "m²")
txt = Replace(txt, "km2", "km²")
txt = Replace(txt, "Km2", "km²")
txt = Replace(txt, "O2", "O" & ChrW(8322))
txt = Replace(txt, "N2", "N" & ChrW(8322))
' Ajout d'un espace entre le chiffre et l'unité (m, km, etc.)
txt = RegReplace(txt, "(\d)(m|k|M|g|t|h|H|o|K|C|O|N|R|B|T|€|%)", "$1 $2")
' Liste des polices système par défaut d'Office 365
Dim acceptedFonts As Variant
acceptedFonts = Array("Arial", "Calibri", "Times New Roman", "Cambria", "Georgia", "Verdana", "Tahoma", _
"Segoe UI", "Courier New", "Consolas", "Lucida Console", "Garamond", "Palatino Linotype", _
"Book Antiqua", "Microsoft Sans Serif", "Century Gothic", "Frank Ruhl Libre", "Arial Narrow", _
"Bookman Old Style", "Corbel", "Candara", "Lucida Sans Unicode", "Calibri Light", "Perpetua", _
"Avenir", "Cambria Math", "Impact", "Sitka", "Rockwell", "Arial Black", "Helvetica", _
"Open Sans", "Montserrat", "Trebuchet MS", "Andalus", "Mongolian Baiti", "Ebrima", _
"Nirmala UI", "Frank Ruhl", "MS Sans Serif")
' Vérification de la police
Dim currentFont As String
currentFont = tr.Font.Name
Dim fontFound As Boolean
fontFound = False
' Vérification si la police fait partie des polices autorisées
For i = LBound(acceptedFonts) To UBound(acceptedFonts)
If LCase(currentFont) = LCase(acceptedFonts(i)) Then
fontFound = True
Exit For
End If
Next i
' Si la police n'est pas dans la liste des polices acceptées
' on ne la modifie PAS si c’est un placeholder
If Not fontFound Then
If Not tr.Parent.PlaceholderFormat.Type <> ppPlaceholderNone Then
' Ne rien faire si c'est un placeholder
Else
tr.Font.Name = "Arial"
End If
End If
' Cas pour MWh, GWh, et autres unités similaires
txt = Replace(txt, "mWh", "MWh")
txt = Replace(txt, "MwH", "MWh")
txt = Replace(txt, "Mwh", "MWh")
txt = Replace(txt, "mwh", "MWh")
txt = Replace(txt, "gWh", "GWh")
txt = Replace(txt, "GwH", "GWh")
txt = Replace(txt, "Gwh", "GWh")
txt = Replace(txt, "gwh", "GWh")
' Cas pour EnR2 et ses variantes
txt = Replace(txt, "EnR", "EnR")
txt = Replace(txt, "ENr", "EnR")
' Application du format des milliers
Do
oldTxt = txt
txt = RegReplace(txt, "(\d)[.,](\d{3})([^0-9]|$)", "$1$2$3")
Loop While txt <> oldTxt
txt = FormatThousandsSansDates(txt)
txt = RegReplace(txt, "(\d)\.(\d)", "$1,$2")
txt = RegReplace(txt, "[ \t]{1,}([!?])", " $1")
txt = RegReplace(txt, "([^ ])([!?])", "$1 $2")
txt = RegReplace(txt, "«\s*", "« ")
txt = RegReplace(txt, "\s*»", " »")
txt = RegReplace(txt, "([([{])\s+", "$1")
txt = RegReplace(txt, "\s+([)\]}])", "$1")
txt = Replace(txt, "((", "(")
txt = Replace(txt, "))", ")")
txt = Replace(txt, "[[", "[")
txt = Replace(txt, "]]", "]")
txt = Replace(txt, "{{", "{")
txt = Replace(txt, "}}", "}")
txt = RegReplace(txt, "\s*–\s*", " – ")
txt = RegReplace(txt, " {2,}", " ")
txt = RegReplace(txt, "€(\d+)", "$1" & fineInsec & "€")
txt = RegReplace(txt, "€\s*(\d+)", "$1" & fineInsec & "€")
txt = RegReplace(txt, "€M (\d+)", "$1" & fineInsec & "M€")
txt = RegReplace(txt, "(\d+)%", "$1" & fineInsec & "%")
' Gestion des indices pour les suffixes
For n = 1 To 99
txt = Replace(txt, CStr(n) & "ème", CStr(n) & ChrW(7497) & ChrW(7504) & ChrW(7497))
txt = Replace(txt, CStr(n) & "eme", CStr(n) & ChrW(7497) & ChrW(7504) & ChrW(7497))
Next n
txt = Replace(txt, "1er", "1" & ChrW(7497) & ChrW(691))
txt = Replace(txt, "2e", "2" & ChrW(7497))
txt = Replace(txt, "1re", "1" & ChrW(691) & ChrW(7497))
txt = Replace(txt, "1ère", "1" & ChrW(7497) & ChrW(691) & ChrW(7497))
txt = Replace(txt, "1st", "1" & ChrW(738) & ChrW(7511))
txt = Replace(txt, "2nd", "2" & ChrW(8319) & ChrW(7496))
txt = Replace(txt, "3rd", "3" & ChrW(691) & ChrW(7496))
' Nettoyage des combinaisons espaces/insécables
Dim combinaisons(1 To 15) As String
combinaisons(1) = Chr(32) & Chr(32)
combinaisons(2) = ChrW(160) & ChrW(160)
combinaisons(3) = ChrW(160) & ChrW(160) & ChrW(160)
combinaisons(4) = Chr(32) & ChrW(160)
combinaisons(5) = ChrW(160) & Chr(32)
combinaisons(6) = Chr(32) & Chr(32) & Chr(32)
combinaisons(7) = Chr(32) & Chr(32) & ChrW(160)
combinaisons(8) = ChrW(160) & Chr(32) & Chr(32)
combinaisons(9) = ChrW(160) & Chr(32) & Chr(32) & Chr(32)
combinaisons(10) = Chr(32) & Chr(32) & Chr(32)
combinaisons(11) = Chr(32) & Chr(32) & Chr(32) & Chr(32)
combinaisons(12) = Chr(32) & Chr(32) & Chr(32) & Chr(32) & Chr(32)
combinaisons(13) = Chr(32) & Chr(32) & Chr(32) & Chr(32) & Chr(32) & Chr(32)
combinaisons(14) = Chr(32) & Chr(32) & Chr(32) & Chr(32) & Chr(32) & Chr(32) & Chr(32)
combinaisons(15) = Chr(32) & Chr(32) & Chr(32) & Chr(32) & Chr(32) & Chr(32) & Chr(32) & Chr(32)
For i = LBound(combinaisons) To UBound(combinaisons)
Do While InStr(txt, combinaisons(i)) > 0
txt = Replace(txt, combinaisons(i), " ")
Loop
Next i
' Supprimer les espaces en début de ligne
txt = RegReplace(txt, "^\s+", "")
If tr.text <> txt Then
tr.text = txt
modifs = modifs + 1
End If
CleanTextRange = modifs
End Function
' Fonction qui utilise VBScript.RegExp pour effectuer les remplacements
Private Function RegReplace(inputText As String, pattern As String, replacement As String) As String
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
regex.Global = True
regex.IgnoreCase = False
regex.pattern = pattern
RegReplace = regex.Replace(inputText, replacement)
End Function
Private Function FormatThousandsSansDates(inputText As String) As String
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
' 1. Extraction des dates de type "en 2025", "de 1980", etc.
Dim protections As Variant
protections = Array("en", "En", "sur", "travers", "année", "années", "courant", "et", "entre", "Entre", "ici", "D'ici")
Dim i As Long, tagId As Long: tagId = 1
Dim matches() As String
ReDim matches(1 To 1)
For i = LBound(protections) To UBound(protections)
Set regex = CreateObject("VBScript.RegExp")
regex.Global = True
regex.IgnoreCase = True
regex.pattern = protections(i) & " (\d{4})"
Do While regex.Test(inputText)
Dim matchVal As String
matchVal = regex.Execute(inputText)(0).Value
matches(tagId) = matchVal
inputText = Replace(inputText, matchVal, "[ANNEE" & tagId & "]")
tagId = tagId + 1
ReDim Preserve matches(1 To tagId)
Loop
Next i
' 2. Supprimer les points/virgules dans les grands nombres (ex: 1.000.000 ? 1000000)
Set regex = CreateObject("VBScript.RegExp")
regex.Global = True
regex.IgnoreCase = False
regex.pattern = "(\d)[.,](\d{3})([^0-9]|$)"
inputText = regex.Replace(inputText, "$1$2$3")
' 3. Ajout des espaces fines insécables entre les milliers
Set regex = CreateObject("VBScript.RegExp")
regex.Global = True
regex.IgnoreCase = False
regex.pattern = "(\d)(?=(\d{3})+(?!\d))"
inputText = regex.Replace(inputText, "$1" & ChrW(8239)) ' espace fine insécable
' 4. Réintégrer les séquences protégées
For i = 1 To UBound(matches) - 1
inputText = Replace(inputText, "[ANNEE" & i & "]", matches(i))
Next i
FormatThousandsSansDates = inputText
End Function |
