[PPT-2007] Mise en Forme de texte par VBA

Bonjour.

Je suis actuellement en train de développer une interface via Excel pour mettre à jour un PPt de façon automatique.
L'objectif est de récupérer dans différentes colonnes d'Excel les valeurs à mettre à jour dans différentes zones de texte nommées dans une diapositive.
Si l'envoi des valeurs vers les zones de texte ne me pose pas de problème, je bute sur leur mise en forme.
Je cherche en fonction de l'existence ou non de la valeur, à modifier une partie de la couleur du texte final.

Voici le code que j'utilise :

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
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
Sub MajCarte()
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
' Génération des variables
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Dim Wb As Workbook                             ' Ce classeur
Dim Chemin As String, Pres As String           ' Emplacement réseau, Nom du PPt
Dim PptApp As PowerPoint.Application           ' Déclaration de l'application PowerPoint
Dim PptDoc As PowerPoint.Presentation          ' Déclaration du PPt
Dim objSld As PowerPoint.Slide                 ' va permettre de parcourir les diapositives du diaporama
Dim objShp As PowerPoint.Shape                 ' va permettre de parcourir les éléments d'une diapositive
Dim strNom As String                           ' valeur du nouveau nom
Dim a As Variant, b As Variant                   ' variables servant à stocker les valeurs à mettre dans les shapes
Dim c As Variant, d As Variant                   ' variables servant à stocker les valeurs à mettre dans les shapes
Dim rnNom As Range, rnCell As Range            ' Plage de cellules contenant le nom des shapes
Dim z as Single                                        ' Compteur
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
 
Set Wb = ActiveWorkbook
Chemin = Wb.Path
Pres = "CARTE.pptx"
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
'Ouverture de l'instance Powerpoint xxxxxxxxxxxxxxxxxxxxxxx
Set PptApp = CreateObject("Powerpoint.Application")
PptApp.Visible = True
 
Set PptDoc = PptApp.Presentations.Open(Chemin & "\" & Pres, WithWindow:=msoFalse)
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
 
Sheets("Temp").Activate
 
'Initialisation de la valeur du z
Range("A1").Offset.End(xlDown).Select
z = ActiveCell.Row
 
'Récupération des valeurs pour mise à jour
 
With ActiveSheet
    Set rnNom = Range(Range("A2"), Range("A" & z)) '.End(xlDown))
 
    For Each rnCell In rnNom
    rnCell.Select
    a = ActiveCell.Value              'Nom de la forme à chercher dans le PPt
    b = ActiveCell.Offset(0, 4).Value 'Nom (valeur de remplacement) de la commune
    c = ActiveCell.Offset(0, 5).Value 'Km S1
    d = ActiveCell.Offset(0, 6).Value 'Km S23
 
'Génération du texte de remplacement et envoi vers la carte
 
        With PptDoc.Slides(1).Shapes(a)
 
            Select Case c
                Case Is = ""
                    If d <> "" Then
                        .TextFrame.TextRange.Text = d & vbCrLf & b
                    End If
                    If d = "" Then
                        .TextFrame.TextRange.Text = b
                    End If
                Case Is <> ""
                    If d <> "" Then
                        .TextFrame.TextRange.Text = c & " - " & d & vbCrLf & b
                    End If
                    If d = "" Then
                        .TextFrame.TextRange.Text = c & vbCrLf & b
                    End If
            End Select
 
        End With
 
' C'est ici que je bloque car je souhaite passer une mise en forme dédiée à chaque variable b, c et d.
' Cette mise en forme ci dessous ne gère que la zone en entier
 
        With PptDoc.Slides(1).Shapes(a).TextFrame.TextRange
            ' modification de la police
            .Font.Name = "Calibri"
            .Font.Bold = msoTrue
            .Font.Size = 8
            .Font.Color = 0
        End With
        With PptDoc.Slides(1).Shapes(a)
            'centrage de la police
            .TextEffect.Alignment = msoTextEffectAlignmentCentered
        End With
 
    Next
End With
 
 
'Sauvegarde la présentation dans le même répertoire que le classeur excel contenant la macro.
 
PptDoc.SaveAs Filename:=Wb.Path & "\" & Pres
 
'ferme la présentation
PptDoc.Close
'ferme powerpoint
PptApp.Quit
 
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
 
MsgBox "L'opération de mise à jour de la carte est terminée."
 
End Sub

Ce que je cherche à faire mais sans y arriver c'est de mettre de couleurs différentes le texte correspondant aux variables b,c et d.
Par exemple d en bleu, c en rouge et b en noir.

Je vous remercie par avance de votre aide qui me sera très précieuse.
Amicalement.

Je vous joins les deux fichiers me servant à cette réalisation :