[VBA-W]Trouver TOUTES couleur sauf le noir ?

[kitcreanet]

Bonjour à tous !

Je cherche à baliser via un chercher remplacer tout les mots de couleur dans un texte (peu importe la couleur). Au final, j'ai besoin que tout ce qui n'est pas noir soit l'objet de ma recherche...

Je n'ai pas trouvé d'instruction pour faire comme dans ce pseudo-code:

Code :

1
2
 
Si couleur du texte ='pas noir' alors sélectionne le...

Une idée ?

Merci d'avance !
(je cherche une solution qui fonctionnerait idéalement sur mac et pc...)

[bbil]

et ton texte il est écrit ou ..? sur un bipMap...

[kitcreanet]

Effectivement, une précision s'impose ;-)
Je dois effectuer cette recherche sur Microsoft Word ;-)

Mille excuses, la prochaine fois je relis mon post avant de le soumettre histoire de voir si il ne manque pas d'infos ;-)

[bbil]

tiens un début de code (à améliorer sans doute..) qui encadre de [ et ] tous le texte non noir du document actif..

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 
Sub ChercheCouleur()
  Dim c As Range
  Dim cMemo As Range
  Dim cFin As Range
  Dim r As Range
  Dim i As Integer
  For i = 1 To ActiveDocument.Characters.Count + 1
    Set c = ActiveDocument.Characters(i)
    Debug.Print c
     Select Case c.Font.Color
       Case wdColorAutomatic, wdColorBlack
       If Not (cMemo Is Nothing) Then
         Debug.Print "Fin  couleur " & c
         Set cFin = c
         Set r = ActiveDocument.Range(Start:=cMemo.Start, End:=cFin.End)
         r.Text = "[" & r.Text & "]"
         i = i + 2 'On passe les [ et ]
         Set cMemo = Nothing
       End If
       Case Else
       If cMemo Is Nothing Then
         Debug.Print "Debut couleur " & c
         Set cMemo = c
       End If
     End Select
  Next
 
End Sub

[kitcreanet]

Merci pour cette aide !
Effectivement, après ça il est facile pour moi de continuer.
(PS: ça fonctionne nickel sur PC comme sur MAC !)

Moi qui débute en VBA, pourrais tu avoir la gentillesse (c'est déjà très gentil de m'aider) de commenter ton code ?

J'ai à coeur de comprendre tout ce que je fais et de tirer un enrichissement à chaque fois que c'est possible. Ton code va me servir mais je ne veux pas l'appliquer bêtement sans comprendre. J'aimerais savoir 'dans le détail' ce qu'il fait. Je comprends certaines actions, d'autres moins.

Merci encore !

[kitcreanet]

Re-Hello.
Ta macro fonctionne bien pour quelques lignes mais dès que l'on atteint 20, 30, 40 lignes, un fort ralentissement apparait.
Sur un document de 4 pages avec une dizaine de mots en couleurs par page, après deux minutes d'attente, je me suis résolu à "tuer" Word qui ne répondait plus ... (Vesion PC)...

Je n'ose imaginer le temps nécessaires pour traiter 300 pages...

Je crois que la solution n'est pas ici ;-)

Encore merci de ton intérêt.
PS: Je veux quand même bien que tu commentes ton code ;-) j'ai de toute façon des choses à apprendre avec lui ;-) ... MERCi

[bbil]

je vais essayer de le commenter ...

déclaration des variables utilisées:

Code :

1
2
3
4
5
Dim c As Range
  Dim cMemo As Range
  Dim cFin As Range
  Dim r As Range
  Dim i As Integer

Boucle parcourant tous les caractéres du document ( j'ai utilisé une boucle For i = 1 To nombre de caractéres, plutôt que une For Each c in ... pour pouvoir "sauter" les caractéres insérés..)

Code :

1
2
3
 
  For i = 1 To ActiveDocument.Characters.Count + 1
    Set c = ActiveDocument.Characters(i)

c est le carctére courant...

Choix suivant couleur caractére courant :

Code :

     Select Case c.Font.Color

Cas où caractére noir (ou couleur automatique), si un début de Zone en couleur est mémorisé (cMemo non null), défini la fin de la zone puis traite la zone en couleur...

Code :

1
2
3
 
      Case wdColorAutomatic, wdColorBlack
       If Not (cMemo Is Nothing) Then

Traitement sur "Fin Couleur", rajoute les carctéres [ et ] au texte sélectionné.. incrémente l'index caractére traité de 2 afin de "sauter" ces 2 caractéres...

Code :

1
2
3
4
5
6
7
8
 
         Debug.Print "Fin  couleur " & c
         Set cFin = c
         Set r = ActiveDocument.Range(Start:=cMemo.Start, End:=cFin.End)
         r.Text = "[" & r.Text & "]"
         i = i + 2 'On passe les [ et ]
         Set cMemo = Nothing
       End If

dans les autres cas .. "en couleur", si début de Zone en couleur non mémorisé on le mémorise..

Code :

1
2
3
4
5
6
7
8
9
10
 
       Case Else
       If cMemo Is Nothing Then
         Debug.Print "Debut couleur " & c
         Set cMemo = c
       End If
     End Select
  Next
 
End Sub

voilà j'espére que c'est plus clair...

[kitcreanet]

Merci pour ces commentaires, c'est très instructif !
Je note, j'apprends, en attendant de pouvoir moi aussi apporter mon aide ;-)