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