Références‎ > ‎

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


Comments