cjoint

Publicité


Publicité

Format du document : text/plain

Prévisualisation

Option Explicit
Sub RemplaceparImages2()
Dim couleurs() As Variant
Dim liens() As Variant
Dim nbR() As String ' compteurs de remplacement
Dim nbM As Long ' nombre de mots du dosument
Dim doc As Document
Dim ic As Long
Dim im As Long
Dim r As Range
Dim ils As InlineShape
Dim hauteur As Single
Dim longueur As Single
Dim nbEsp As Long
Dim texte As String
Dim trouvé As Boolean
Debug.Print Now
' ADAPTER ICI ========================
' attention : respecter la casse
couleurs = Array("ROUGE", "VERT", "JAUNE")
liens = Array("D:\Icones\patins.ico", "D:\Icones\biere.ico", "D:\Icones\peche.ico")
hauteur = 12 ' fixe la hauteur des images.
longueur = 20.5
' ===================================
If UBound(couleurs) <> UBound(liens) Then
MsgBox "Les deux listes sont incohérentes"
End
End If
ReDim nbR(UBound(couleurs))
Set doc = ActiveDocument
'initialise les compteurs
For ic = 0 To UBound(nbR)
nbR(ic) = 0
Next ic
nbM = doc.Words.count
Debug.Print nbM
' balayage des couleurs
For ic = 0 To UBound(nbR)
Selection.HomeKey unit:=wdStory, Extend:=wdMove
Do
With Selection.Find
.ClearFormatting
.Text = couleurs(ic)
.MatchCase = True
.Forward = True
.Wrap = wdFindContinue
trouvé = .Execute
If trouvé Then
Selection.Range.Delete
Set r = Selection.Range
Set ils = doc.InlineShapes.AddPicture(FileName:=liens(ic), linktofile:=False, savewithdocument:=True, Range:=r)
' juste pour l'exemple
ils.Height = hauteur
ils.Width = longueur
Selection.Collapse (wdCollapseEnd)
nbR(ic) = nbR(ic) + 1
Else
' pas trouvé : fin = fin du document
Debug.Print
Exit Do
End If
End With
Loop
Next ic

texte = ""
For ic = 0 To UBound(nbR)
Debug.Print couleurs(ic), nbR(ic)
texte = texte & couleurs(ic) & " : " & nbR(ic) & vbCrLf
Next ic
Debug.Print Now
MsgBox texte

End Sub

Publicité


Signaler le contenu de ce document

Publicité