Impasse code VBA complexe - Plus fort que chatGPT ?

**MDK75** · 22/04/2025, 14h28

Bonjour !

Cela fait quelques jours et quelques nuits que j'essaie de faire fonctionner ce code pour pouvoir corriger les éléments de ponctuation dans une présentation française.

Le code et les transformations opérés sont un succès mais malheureusement, cela change l'apparence du texte modifié : le style du texte est modifié quand 2 mots ont un style différent (taille / graisse / etc) au sein d'une même zone de texte.

Auriez-vous une solution pour que ces changements soient opérés dans le masque, dans les notes, dans les lsides et dans les tableaux, sans que la mise en forme source soit modifiée ?

Un grand merci pour votre aide !

Benjamin

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Nom : Avant.png
Affichages : 118
Taille : 27,8 Ko

Nom : Apres.png
Affichages : 117
Taille : 130,2 Ko

**MDK75** · 24/04/2025, 08h20

Y a-t-il quelqu'un qui puisse m'aider ?

Merci,

**Nain porte koi** · 24/04/2025, 09h41

Hello,

je ne pense pas qu'il y ait de solution simple car vos macros travaillent au niveau du contenu sans tenir compte de la mise en forme.
A mon sens il faudrait garder la mise en forme caractère par caractère et la réappliquer aux changements, ce qui me semble infaisable vu que les changements ne sont pas forcément de la même taille que ceux qui étaient avant.

**rMist2024** · 24/04/2025, 11h49

Il y a la propriété Runs de TextRange qui regroupe les passages ayant même style donc au lieu d'appliquer le nettoyage sur l’ensemble du texte essaie de l'appliquer individuellement sur chaque run.

Changer le mon de CleanTextRange à CleanTextRange2
et ajouter cette nouvelle version de CleanTextRange qui utilise en interne l'ancienne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Private Function CleanTextRange(tr As TextRange) As Long
    Dim modifs As Long: modifs = 0
    Dim vr, rg As TextRange
    For Each vr In tr.Runs
       Set rg = vr
       modifs = modifs + CleanTextRange2(rg)
    Next
   CleanTextRange = modifs
End Function

**MDK75** · 24/04/2025, 15h03

Merci beaucoup pour vos réponses.

@rMist2024

Ta solution a fonctionné bravo à toi

j'ai passé plusieurs jours avec Chat qui ne trouvait pas la bonne méthode...

Un grand merci pour avoir pris le temps de regarder ce code.

A bienôt,

**Nain porte koi** · 24/04/2025, 16h07

Les forums c'est génial, ça permet d'en apprendre toujours un peu plus, merci rMist2024

**MDK75** · 27/04/2025, 21h43

Bonjour,

Voici le code amélioré et enrichie qui fonctionne plutôt bien gâce à votre aide.

**rMist2024** · 28/04/2025, 10h15

Je pense que la suppression de certains type de textes comme les espaces pourrait poser problème puisque le span devrait etre entièrement supprimé et c'est compliqué avec les runs alors la méthode Replace de TextRange permet de remplacer le texte sans modifier le style.

https://learn.microsoft.com/en-us/of...tRange.Replace

Cette méthode promet d’être lente donc à appliquer seulement sur les types qui posent problème

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Private Function TxtRep(ByVal tr As TextRange, aFind As String, ByVal RepTxt As String) As Long
  Dim nw As TextRange
  Do
      Set nw = tr.Replace(aFind, RepTxt, msoFalse, msoFalse)
      If nw Is Nothing Then Exit Do
      Set tr = tr.Characters(nw.Start + nw.Length, tr.Length)
      TxtRep = TxtRep + 1
  Loop
End Function

**MDK75** · 28/04/2025, 13h07

Merci rMist2024,

Mais j'ai tjrs des sauts de lignes phantomes. Tant pis, je ferais avec merci en tous cas.

A +

Benjamin

Impasse code VBA complexe - Plus fort que chatGPT ? [PPT-365]

VBA PowerPoint

Discussions similaires

Partager

Partager