Macro pour supprimer le gris (2)

Sub AutoDeleteGray()

'Delete only the last gray in the same paragraph

Dim length As Integer

Selectionstart = Selection.range.Start

p = Selection.Paragraphs.First

dd = Selection.range.HighlightColorIndex

Do While Selection.Characters.First.HighlightColorIndex = wdGray25

    If (Selection.MoveRight <> 1) Then Exit Do

Loop

backupForward = Selection.Find.Forward

backupText = Selection.Find.Text

backupMatchWildcards = Selection.Find.MatchWildcards

 With Selection.Find

        .Highlight = True

        .Text = "\{\>*\<\}"

        .Replacement.Text = ""

        .Forward = False

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = True

        .MatchSoundsLike = False

        .MatchAllWordForms = False

         If .Execute = True Then

            ParagraphFirst = Selection.Paragraphs.First

            ParagraphLast = Selection.Paragraphs.Last

            If ParagraphFirst = p Or ParagraphLast = p Then

                If Selection.range.HighlightColorIndex = wdGray25 Or Selection.range.HighlightColorIndex = wdUndefined Then

                    IsValid = True

                    For Each c In Selection.range.Characters

                       If c.HighlightColorIndex <> wdGray25 And c.HighlightColorIndex <> wdUndefined Then

                            IsValid = False

                            Exit For

                       End If

                    Next c

                Else

                    Selection.range.Start = Selection.range.End

                 End If

            Else

                IsValid = False

            End If

        Else

            IsValid = False

         End If

       If IsValid Then

        length = Selection.range.End - Selection.range.Start

        deleteAll Selection.range

       Else

        Selection.range.Start = Selection.range.End

        End If

    End With

    Selection.Start = Selectionstart - length

    Selection.End = Selectionstart - length

    Selection.Find.MatchWildcards = backupMatchWildcards

    Selection.Find.Forward = backupForward

    Selection.Find.Text = backupText

End Sub

Sub AutoDeleteGrayAll()

'Delete All Gray

Dim lastRange As Integer

Dim error As Integer

If MsgBox("Désirez-vous nettoyer votre document ?", vbOKCancel) = vbOK Then

On Error GoTo doCleanup

'Application.ScreenUpdating = False

Selection.HomeKey Unit:=wdStory

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

    Do

    IsValid = True

    With Selection.Find

        .Highlight = True

        .Text = "\{\>*\<\}"

        .Replacement.Text = ""

        .Forward = True

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = True

        .MatchSoundsLike = False

        .MatchAllWordForms = False

         If .Execute = True Then

            If Selection.range.HighlightColorIndex = wdGray25 Or Selection.range.HighlightColorIndex = wdUndefined Then

                IsValid = True

                For Each c In Selection.range.Characters

                   If c.HighlightColorIndex <> wdGray25 And c.HighlightColorIndex <> wdUndefined Then

                        IsValid = False

                        error = error + 1

                        Exit For

                   End If

                Next c

            Else

                Selection.range.Start = Selection.range.End

             End If

        Else

            Exit Do

         End If

       If IsValid Then

        deleteAll Selection.range

       Else

        Selection.range.Start = Selection.range.End

       End If

    End With

    Loop While (True)

For Each myStoryRange In ActiveDocument.StoryRanges

   If myStoryRange.StoryType <> wdMainTextStory Then

        With myStoryRange.Find

        .Highlight = True

        .Text = "\{\>*\<\}"

        .Replacement.Text = ""

        .Forward = True

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = True

        .MatchSoundsLike = False

        .MatchAllWordForms = False

         If .Execute = True Then

            If myStoryRange.HighlightColorIndex = wdGray25 Or myStoryRange.HighlightColorIndex = wdUndefined Then

                IsValid = True

                For Each c In myStoryRange.Characters

                   If c.HighlightColorIndex <> wdGray25 And c.HighlightColorIndex <> wdUndefined Then

                        IsValid = False

                        error = error + 1

                        Exit For

                   End If

                Next c

            Else

                myStoryRange.Start = myStoryRange.End

             End If

        Else

            IsValid = False

         End If

       If IsValid Then

        deleteAll myStoryRange

       Else

        myStoryRange.Start = myStoryRange.End

       End If

    End With

    End If

Next myStoryRange

doCleanup:

'Application.ScreenUpdating = True

If (Err.Number <> 0) Then

    MsgBox "Nettoyage complété avec 1 erreur(s). (" + Err.Description + ")"

Else

    MsgBox "Nettoyage complété avec " + CStr(error) + " erreur(s)"

End If

End If

End Sub

Function deleteAll(ByVal r As range)

    With r.Find

        .Text = "\{\>*\<\}"

        .Replacement.Text = ""

        .Forward = True

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = True

        .MatchSoundsLike = False

        .MatchAllWordForms = False

        .Execute Replace:=wdReplaceOne

    End With

End Function