Macro Word - Automatiser la couleur de certains mots

Question

Bonjour,

Je chercher au automatiser le changement de couleur dans mon texte par un bouton qui lancerait une Macro. J'arrive à baragouiner quelques notions de VBA sur Excel, mais là, sur Word, je sais pas pourquoi mais je pêche total...

Je détaille ma requête :

J'ai certains mots de mon texte (et même une bordure) qui sont orange. J'aimerais, quand je clique sur le bouton de ma macro, qu'une pop up s'ouvre où je puisse taper un code hexa d'une autre couleur, pour changer la couleur de ces mots.

A moins que la méthode ne soit pas la bonne et qu'il existe une solution plus simple ! Je suis ouvert à toute proposition du moment que le changement de ma couleur se fasse en auto.

Merci beaucoup d'avance !

Answer 1

Merci encore !!

Malheureusement il y a un problème au niveau des Case :

Case WdStoryType.wdEvenPagesHeaderStory, _

                 WdStoryType.wdPrimaryHeaderStory, \_ 

                 WdStoryType.wdEvenPagesFooterStory, \_ 

                 WdStoryType.wdPrimaryFooterStory, \_ 

                 WdStoryType.wdFirstPageHeaderStory, \_

Et je suis bien incapable de savoir quoi, mais la macro ne se lance même pas, j'ai un message "Erreur de compilation : utilisation incorrecte de la propriété"

Answer 2

Bonjour

Sélectionner un mot ayant la couleur à modifier puis lancer FindTt

' Avant la 1ere sub !!!

Dim lgCouleurAvant As Long

Dim lgCouleurFin As Long

Public Sub FindTt()

    Dim rngStory As Word.Range

    Dim pReplaceTxt As String

    Dim lngJunk As Long

    Dim oShp As Shape

    lgCouleurAvant = Selection.Font.Fill.ForeColor.RGB

    Selection.HomeKey Unit:=wdStory ' Va au début du document

    ' Si une sélection est faite, ne fonctionne que sur celle-ci !

    lgCouleurFin = hexa_color(InputBox("Code hexa de la couleur (ex : #FF0000)", "Nouvelle couleur"))     ' !!! la saisie utilisateur n'est pas vérifiée !

    'Fix the skipped blank Header/Footer problem

    lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType

    'Iterate through all story types in the current document

    For Each rngStory In ActiveDocument.StoryRanges

        'Iterate through all linked stories

        Do

            SearchAndReplaceInStory rngStory

            On Error Resume Next

            Select Case rngStory.StoryType

                Case WdStoryType.wdEvenPagesHeaderStory, _

                     WdStoryType.wdPrimaryHeaderStory, _

                     WdStoryType.wdEvenPagesFooterStory, _

                     WdStoryType.wdPrimaryFooterStory, _

                     WdStoryType.wdFirstPageHeaderStory, _

                     WdStoryType.wdFirstPageFooterStory

                    If rngStory.ShapeRange.Count > 0 Then

                        For Each oShp In rngStory.ShapeRange

                            If oShp.TextFrame.HasText Then

                                SearchAndReplaceInStory oShp.TextFrame.TextRange

                            End If

                        Next

                    End If

                Case Else

                    'Rien

                End Select

                Set rngStory = rngStory.NextStoryRange

            Loop Until rngStory Is Nothing

        Next

End Sub

Public Sub SearchAndReplaceInStory(ByVal rngStory As Word.Range)

    With rngStory.Find

        .ClearFormatting

        .Replacement.ClearFormatting

        .Font.Color = lgCouleurAvant

        .Replacement.Font.Color = lgCouleurFin

        .Execute Replace:=wdReplaceAll

    End With

End Sub

Function hexa_color(ByVal hexa) 'Returns -1 in case of error

'Convert a hexadecimal color to a Color value - Excel-Pratique.com

'www.excel-pratique.com/en/vba_tricks/hexadecimal-color-function

If Len(hexa) = 7 Then

    hexa = Mid(hexa, 2, 6) 'If color with #

    If Len(hexa) = 6 Then

        num_array = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "a", "b", "c", "d", "e", "f")

        char1 = LCase(Mid(hexa, 1, 1))

        char2 = LCase(Mid(hexa, 2, 1))

        char3 = LCase(Mid(hexa, 3, 1))

        char4 = LCase(Mid(hexa, 4, 1))

        char5 = LCase(Mid(hexa, 5, 1))

        char6 = LCase(Mid(hexa, 6, 1))

        For i = 0 To 15

            If (char1 = num_array(i)) Then position1 = i

            If (char2 = num_array(i)) Then position2 = i

            If (char3 = num_array(i)) Then position3 = i

            If (char4 = num_array(i)) Then position4 = i

            If (char5 = num_array(i)) Then position5 = i

            If (char6 = num_array(i)) Then position6 = i

        Next

        If IsEmpty(position1) Or IsEmpty(position2) Or IsEmpty(position3) Or IsEmpty(position4) Or IsEmpty(position5) Or IsEmpty(position6) Then

            hexa_color = -1

        Else

            hexa_color = RGB(position1 * 16 + position2, position3 * 16 + position4, position5 * 16 + position6)

        End If

    Else

    hexa_color = -1

    End If

End If

End Function

Answer 3

Bonjour et merci Hecatonchire ! Ca marche nickel !

J'ai juste 2 petits soucis au niveau de la recherche de ce qui est orange dans le texte :

1/La macro ne modifie la couleur que pour les mots placés après le curseur

2/J'ai des mots orange placés dans des formes, dans l'en-tête et même une bordure et ils ne sont pas pris en compte non plus (ouais je sais je me complique la vie...)

Comment faire pour que le document en entier soit pris en compte par la recherche de la couleur ?

Autre petit soucis : Une fois la couleur modifié 1 fois, je ne peux plus la changer à nouveau.

Merci d'avance !

Answer 4

Bonjour

Faisable manuellement via la commande Remplacer (Ruban Accueil/Home) sinon

Sub Macro3()

Dim strCouleur as long

' Si une sélection est faite, ne fonctionne que sur celle-ci !

strCouleur = hexa_color(InputBox("Code hexa de la couleur (ex : #FF0000)", "Nouvelle couleur")) ' !!! la saisie utilisateur n'est pas vérifiée !

Selection.Find.ClearFormatting

Selection.Find.Font.Color = RGB(255, 192, 0) ' Orange

Selection.Find.Replacement.ClearFormatting

Selection.Find.Replacement.Font.Color = strCouleur

Selection.Find.Execute Replace:=wdReplaceAll

End Sub

Fonction de conversion copié/collé du site tel quel

Function hexa_color(ByVal hexa) 'Returns -1 in case of error

'Convert a hexadecimal color to a Color value - Excel-Pratique.com

'www.excel-pratique.com/en/vba_tricks/hexadecimal-color-function

If Len(hexa) = 7 Then

hexa = Mid(hexa, 2, 6) 'If color with #

If Len(hexa) = 6 Then

num_array = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "a", "b", "c", "d", "e", "f")

char1 = LCase(Mid(hexa, 1, 1))

char2 = LCase(Mid(hexa, 2, 1))

char3 = LCase(Mid(hexa, 3, 1))

char4 = LCase(Mid(hexa, 4, 1))

char5 = LCase(Mid(hexa, 5, 1))

char6 = LCase(Mid(hexa, 6, 1))

For i = 0 To 15

If (char1 = num_array(i)) Then position1 = i

If (char2 = num_array(i)) Then position2 = i

If (char3 = num_array(i)) Then position3 = i

If (char4 = num_array(i)) Then position4 = i

If (char5 = num_array(i)) Then position5 = i

If (char6 = num_array(i)) Then position6 = i

Next

If IsEmpty(position1) Or IsEmpty(position2) Or IsEmpty(position3) Or IsEmpty(position4) Or IsEmpty(position5) Or IsEmpty(position6) Then

hexa_color = -1

Else

hexa_color = RGB(position1 * 16 + position2, position3 * 16 + position4, position5 * 16 + position6)

End If

Else

hexa_color = -1

End If

End Function