[VBA Excel] Ecrire en couleur dans un Word

Version imprimable

Bonjour à toutes et à tous,

J'essaye d'écrire des phrases dans un document Word :

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
30
31
32
33
34
35
36
37
38
39
40
41
' Définition du fichier Word
    Dim FichierWord As Object
    Set FichierWord = New Word.Application
    'Set FichierWord = CreateObject("Word.Application")
 
    ' Création du document
    FichierWord.Documents.Add 'DocumentType:=wdNewBlankDocument
 
    ' Ecriture du résultats
    For lngCpt = 1 To Main.lstFichiers.ListCount
 
        tabSplit = Split(lstFichiers.List(lngCpt - 1), vbTab)
 
        If tabSplit(0) <> "" Then
            ' Ecriture dans le document
            FichierWord.Selection.TypeText tabSplit(0) & vbCrLf
            FichierWord.Selection.MoveUp Unit:=wdLine, Count:=3, Extend:=wdExtend
            With Selection.Font
                .Color = wdColorRed
            End With
        Else
            ' Ecriture dans le document
            FichierWord.Selection.TypeText vbTab & tabSplit(1) & vbCrLf
            FichierWord.Selection.MoveUp Unit:=wdLine, Count:=3, Extend:=wdExtend
            With Selection.Font
                .Color = wdColorBlue
            End With
        End If
 
        FichierWord.Selection.EndOf Unit:=wdStory, Extend:=wdMove
    Next lngCpt
 
    ' Sauvegarde du document
    FichierWord.ActiveDocument.SaveAs CHEMIN_SCANNER & "\Résultats.doc"
 
    ' Fermeture du document
    FichierWord.ActiveDocument.Close
    FichierWord.Application.Quit
 
    ' On détruit l'objet
    Set FichierWord = Nothing

Problème : Seul le texte apparaît dans le document et sans être en couleur ;-(

bonsoir

tu peux tester et adapter cette procédure

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
    Dim AppliWord As Word.Application
    Dim i As Integer
 
    Set AppliWord = New Word.Application
    AppliWord.Visible = True
 
    AppliWord.Documents.Add
 
    For i = 1 To 16
        With AppliWord.Selection
            .Font.ColorIndex = i
            .TypeText Text:="Ligne " & i & vbCrLf
        End With
    Next i

bonne soirée
michel

Bonjour SkillyRoad,

Après avoir adapté un peu, j'ai fini par trouver ce qu'il fallait faire :

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
    ' Définition du fichier Word
    Dim FichierWord As Object
    Set FichierWord = New Word.Application
    'Set FichierWord = CreateObject("Word.Application")
 
    ' Création du document
    FichierWord.Documents.Add 'DocumentType:=wdNewBlankDocument
 
    ' Ecriture du résultats
    For lngCpt = 1 To Main.lstFichiers.ListCount
 
        tabSplit = Split(lstFichiers.List(lngCpt - 1), vbTab)
 
        If tabSplit(0) <> "" Then
            ' Ecriture dans le document
            With FichierWord.Selection
                .Font.Color = wdColorBlue
                .TypeText tabSplit(0) & vbCrLf
            End With
        Else
            ' Ecriture dans le document
            With FichierWord.Selection
                .Font.Color = wdColorRed
                .TypeText vbTab & tabSplit(1) & vbCrLf
            End With
        End If
 
        FichierWord.Selection.EndOf Unit:=wdStory, Extend:=wdMove
    Next lngCpt