Couleur SurfaceTopViewWireframe

Bonjour à tous,

J'ai un soucis sur le code que je réalise. Il s'agit d'une appli pour éditer des graphiques en semi-automatique et dans ce cadre j'essai de faire des graphiques avec les courbes de niveaux.

Je n'arrive cependant pas à automatiser les couleurs des lignes de niveaux...

Voici mon code :

Sub graphique3D(Graph As ChartObject)
Dim i As Integer, h As Double
Dim forMax As Double, forMin As Double, forStep As Double, a As Integer
With Graph.Chart
    .SetSourceData Source:=GetOldRange("Z")
    .ChartType = xlSurfaceTopViewWireframe

    With .Axes(xlValue)
        .MinimumScale = Application.WorksheetFunction.min(GetOldRangeWithOutFirstLineColonne("Z"))
        .MaximumScale = Application.WorksheetFunction.max(GetOldRangeWithOutFirstLineColonne("Z"))
        .MajorUnit = PasPrincipal ''Pas des étiquettes de données
    End With

    If ActiveSheet.OLEObjects("ReverseAxes").Object.Value = True Then
        forMin = ActiveSheet.OLEObjects("Nbpoints").Object.Value: forMax = 1: forStep = -1
    ElseIf ActiveSheet.OLEObjects("ReverseAxes").Object.Value = False Then
        forMin = 1: forMax = ActiveSheet.OLEObjects("Nbpoints").Object.Value: forStep = 1
    Else
        End
    End If

    a = 1
    For i = forMin To forMax Step forStep ''Couleur
        With .Legend.LegendEntries(a) ''Coloration de la légende en fonction de l'algo de couleur
            .Font.Color = RGB((255 / ActiveSheet.OLEObjects("Nbpoints").Object.Value) * i, 0, 0)
        End With

''' Coloration des courbes de niveaux .....

'--------------------------------------------'

    a = a + 1
    Next i

End With

End Sub

Et les fonctions ...

Function PasPrincipal() As Double
Dim nbPoint As Integer, min, max
If ActiveSheet.OLEObjects("Nbpoints").Object.Value <> "" Then
    nbPoint = ActiveSheet.OLEObjects("Nbpoints").Object.Value
Else
    nbPoint = 10
    ActiveSheet.OLEObjects("Nbpoints").Object.Value = 10
End If

min = Application.WorksheetFunction.min(GetOldRangeWithOutFirstLineColonne("Z"))
max = Application.WorksheetFunction.max(GetOldRangeWithOutFirstLineColonne("Z"))

PasPrincipal = (max - min) / nbPoint
End Function

Function GetOldRange(axe As String) As Range
 Set GetOldRange = Range(ActiveSheet.OLEObjects(axe & "Values").Object.Caption)
End Function

Dim rng As String
rng = ActiveSheet.OLEObjects(axe & "Values").Object.Caption
Mid(rng, 2, 1) = "B"
Mid(rng, 4, 1) = 2

Set GetOldRangeWithOutFirstLineColonne = Range(rng)

End Function

En vous remerciant tous par avance

Et en vous remerciant tous pour le passé car ce forum est une mine d'or pour l'apprentissage du VB