Comment marquer les entrées d'index dans les formes

Sub AjouterChampXEDansShapes()
    ' Objectif    : Marquer toutes les entrées d'index correspondantes à un texte dans les zones de texte et formes.
    ' Utilisation : La macro demande le texte à marquer (rechercher) puis le texte de l'entrée.
    ' Retour      : Modification du document actif.
    ' Appels      : Néant.
    ' Auteur      : Arnaud (www.1forme.fr).
    ' Licence     : CC-BY-NC-SA (Vous pouvez diffuser/partager/modifier cette macro dans les même conditions,
    '                           seulement à titre personnel et citant l'auteur/site d'origine.
    
    Dim doc             As Document
    Dim strTxtCherche   As String
    Dim strEntree       As String
    Dim strCodeChamp    As String
    Dim rgDocRange      As Range
    Dim objChamp        As field
    Dim objShape        As shape
    Dim rgTxtShape      As Range
    Dim rgTxtTrouve     As Range
    Dim boTxtDsChamp    As Boolean
    Dim boXEDejaPresent As Boolean
    Dim rgPortionDt     As Range
    Dim boTexteTrouve   As Boolean
    
    Set doc = ActiveDocument
    strTxtCherche = InputBox("Texte à chercher :", "Texte à marquer")
    If (StrPtr(strTxtCherche) = 0) Or (strTxtCherche = vbNullString) Then
        MsgBox "Sans texte à chercher l'exécution est impossible.", vbInformation, "Arret de la macro"
        Exit Sub
    End If
    strEntree = InputBox("Texte de l'entrée correspondante", "Entrée d'index")
     If (StrPtr(strEntree) = 0) Or (strEntree = vbNullString) Then
        MsgBox "Sans valeur d'Entrée le marquage est impossible", vbInformation, "Arret de la macro"
        Exit Sub
    End If
    strCodeChamp = "XE """ & strEntree & """"
    
    ' Ajouter un champ XE à la fin du document
    Set rgDocRange = doc.Content
    rgDocRange.Collapse Direction:=wdCollapseEnd
    Set objChamp = doc.Fields.Add(Range:=rgDocRange, Type:=wdFieldEmpty, Text:=strCodeChamp, PreserveFormatting:=False)

    ' Sélectionner, copier et supprimer le champ XE
    objChamp.Select
    Selection.Copy
    objChamp.Delete

    ' Parcourir toutes les formes du document
    For Each objShape In doc.Shapes
        If objShape.TextFrame.HasText Then ' Vérifier si la forme contient du texte
            Set rgTxtShape = objShape.TextFrame.textRange
            Set rgTxtTrouve = rgTxtShape.Duplicate
            ' Rechercher et marquer le texte "xxx"
            Do While rgTxtTrouve.Find.Execute(FindText:=strTxtCherche, MatchCase:=True, MatchWholeWord:=True)
                ' Vérifier si la plage trouvée est à l'intérieur d'un champ existant
                boTxtDsChamp = False
                boXEDejaPresent = False
                boTexteTrouve = True
                For Each objChamp In rgTxtShape.Fields
                    If rgTxtTrouve.Start >= objChamp.Code.Start And rgTxtTrouve.End <= objChamp.Code.End Then
                        boTxtDsChamp = True
                        Exit For
                    End If
                Next objChamp
                ' Vérifier si un champ XE existe déjà à droite du texte trouvé
                Set rgPortionDt = rgTxtShape.Duplicate
                rgPortionDt.Start = rgPortionDt.Start + rgTxtTrouve.End ' Position de départ à rgTxtTrouve.End caractères dans rgPortionDt
                rgPortionDt.Collapse Direction:=wdCollapseStart
                rgPortionDt.MoveEnd Unit:=wdWord, Count:=5
                If rgPortionDt.Text Like Chr(19) & " " & strCodeChamp & "*" Then
                    boXEDejaPresent = True
                End If
                ' Si aucun champ n'est trouvé dans la plage et qu'il n'est pas déjà marqué, coller le champ XE
                If Not boTxtDsChamp And Not boXEDejaPresent Then
                    rgTxtTrouve.Collapse wdCollapseEnd
                    rgTxtTrouve.Paste
                End If

                ' Déplacer la sélection après le champ collé pour éviter une boucle infinie
                rgTxtTrouve.Start = rgTxtTrouve.End
            Loop
        End If
    Next objShape
    If Not boTexteTrouve Then MsgBox "Texte non trouvé !", vbInformation, "Arret de la macro"
End Sub