Option Explicit

Sub renommeDesEntreesDIndex()
' dialogue pour renommer des entrées d'index
' appel de la fonction pour chaque mot indiqué
' au retour : nombre de renommages effectués

Dim param1 As String
Dim param2 As String
Dim prompt As String
Dim nb As Long
prompt = "Indiquez la valeur que vous voulez renommer dans un index" & vbCrLf
prompt = prompt & "Ne rien indiquer pour terminer le traitement." & vbCrLf
prompt = prompt & "Respecter les majuscules et minuscules."
Do
  param1 = InputBox(prompt, "Entrée d'index à renommer")
  If Len(Trim(param1)) = 0 Then
    MsgBox ("Terminé")
    Exit Sub
  End If
  prompt = "Indiquez la valeur que vous voulez donner à l'index  " & param1 & vbCrLf
  prompt = prompt & "Ne rien indiquer ignore ce renommage et passe au suivant." & vbCrLf
  prompt = prompt & "Respecter les majuscules et minuscules."
  param2 = InputBox(prompt, "Valeur de remplacement")
  If Len(Trim(param2)) > 0 Then
    nb = renommeUneEntreeDIndex(param1, param2)
    prompt = "renommage de : " & param1 & " en " & param2 & vbCrLf & "   " & nb & " Références" & vbCrLf & vbCrLf
    'MsgBox ("Suppression de : " & param & "  " & nb & " Références")
    prompt = prompt & "Renommage suivant : "
  End If
Loop
End Sub

Private Function texteChampXE(ch As Range) As String
' Extrait le texte d'un champ, ici pour une champ XE
Dim d As Long
Dim f As Long
d = InStr(3, ch.Text, Chr(34)) + 1
f = InStr(d, ch.Text, Chr(34))
texteChampXE = carCourants(Mid(ch.Text, d, f - d))
End Function

Private Function renommeUneEntreeDIndex(original As String, renommage As String) As Long
' Efface tous les champs XE vers un mot qui est défini en argument
Dim doc As Document ' document ouvert
Dim Champ As Field, nb As Long
Dim contenuChamp As String
Dim rempl As String
Dim d As Long
Dim f As Long

'Dim mot As String
Set doc = ActiveDocument

'Afficher les codes des champs
nb = 0
ActiveWindow.ActivePane.View.ShowAll = True
For Each Champ In doc.Fields
    If Champ.Type = wdFieldIndexEntry Then ' entrées d'index
    'Debug.Print (Champ.Code.Words.count)
    'Debug.Print ("1 : " & Champ.Code.Words(1))
    'Debug.Print ("2 : " & Champ.Code.Words(2))
    'Debug.Print ("3 : " & Champ.Code.Words(3))
    d = InStr(3, Champ.Code.Text, Chr(34)) + 1
    f = InStr(d, Champ.Code.Text, Chr(34))
      contenuChamp = Mid(Champ.Code.Text, d, f - d)
      If carCourants(contenuChamp) = original Then
        ' remplacement
        rempl = Left(Champ.Code.Text, d - 1) & renommage & Mid(Champ.Code.Text, f)
        Champ.Code.Text = rempl
        nb = nb + 1
      End If
      
    End If
Next
renommeUneEntreeDIndex = nb

End Function
Private Function carCourants(t As String) As String
Dim temp As String
temp = t
'apostrophe
temp = Replace(temp, Chr(146), "'")
'espace insécable
temp = Replace(temp, Chr(160), " ")
carCourants = temp

End Function
Sub supprimeDesEntreesDIndex()
' dialogue pour supprimer des entrées d'index
' appel de la fonction pour chaque mot indiqué
' au retour : nombre de suppressions effectuées

Dim param As String
Dim prompt As String
Dim nb As Long
prompt = "Indiquez un mot que vous voulez supprimer de l'index" & vbCrLf
prompt = prompt & "Ne rien indiquer pour terminer le traitement." & vbCrLf
prompt = prompt & "Respecter les majuscules et minuscules."
Do
  param = InputBox(prompt, "Suppression d'une entrée d'index")
  If Len(Trim(param)) = 0 Then
    MsgBox ("Terminé")
    Exit Sub
  End If
  nb = supprimeUneEntreeDIndex(param)
  prompt = "Suppression de : " & param & "  " & vbCrLf & "   " & nb & " Références" & vbCrLf & vbCrLf
  'MsgBox ("Suppression de : " & param & "  " & nb & " Références")
  prompt = prompt & "Nouveau mot : "
Loop
End Sub

Function supprimeUneEntreeDIndex(mot As String) As Long
' Efface tous les champs XE vers un mot qui est défini en argument
Dim doc As Document ' document ouvert
Dim Champ As Field, nb As Long
Dim contenuChamp As String
'Dim mot As String
Set doc = ActiveDocument

'Afficher les codes des champs
nb = 0
ActiveWindow.ActivePane.View.ShowAll = True
For Each Champ In doc.Fields
    If Champ.Type = wdFieldIndexEntry Then ' entrées d'index
    'Debug.Print (Champ.Code.Words.count)
    'Debug.Print ("1 : " & Champ.Code.Words(1))
    'Debug.Print ("2 : " & Champ.Code.Words(2))
    'Debug.Print ("3 : " & Champ.Code.Words(3))
    'Debug.Print ("4 : " & Champ.Code.Words(4))
    'Debug.Print ("5 : " & Champ.Code.Words(5))
      If texteChampXE(Champ.Code) = mot Then
        Champ.Delete
        nb = nb + 1
      End If
    End If
Next
supprimeUneEntreeDIndex = nb

End Function

Sub entreesDIndexEnItalique()
' dialogue pour mettre en italique des entrées d'index existantes
' appel de la fonction pour chaque mot indiqué
' au retour : nombre de mises en forme effectuées
' i.e. le nombre d'occurence de ce mot

Dim param As String
Dim prompt As String
Dim nb As Long
prompt = "Indiquez le nom de l'entrée que vous voulez mettre en italique. " & vbCrLf
prompt = prompt & "Ne rien indiquer pour terminer le traitement." & vbCrLf
prompt = prompt & "Respecter les majuscules et minuscules."
Do
  param = InputBox(prompt, "Mettre en italique une entrée d'index")
  If Len(Trim(param)) = 0 Then
    MsgBox ("Terminé")
    Exit Sub
  End If
  nb = italiqueEntreeDIndex(param)
  prompt = "Mise en italique de : " & param & "  " & vbCrLf & "   " & nb & " Références" & vbCrLf & vbCrLf
  prompt = prompt & "Nouveau mot : "
Loop
End Sub

Function italiqueEntreeDIndex(mot As String) As Long
' Met en italique les champs XE vers un mot qui est défini en argument
' il suffit de passer la première occurence en italique
Dim doc As Document ' document ouvert
Dim Champ As Field, nb As Long
Dim contenuChamp As String
'Dim mot As String
Set doc = ActiveDocument
' Indiquer ici le texte qui détermine le début du contenu du champ à éliminer
'mot = "Royaune"
'Afficher les codes des champs
nb = 0
ActiveWindow.ActivePane.View.ShowAll = True
For Each Champ In doc.Fields
    If Champ.Type = wdFieldIndexEntry Then ' entrées d'index
      Debug.Print ("'" & texteChampXE(Champ.Code) & "'  '" & mot & "'")
      If texteChampXE(Champ.Code) = mot Then
        Champ.Code.Italic = True
        nb = nb + 1
      End If
    End If
Next
italiqueEntreeDIndex = nb

End Function