Option Explicit

Public Function Degrade(Objet As Object, DebCol As Long, FinCol As Long, Vertical As Integer) As Byte
On Error Resume Next
Dim a As Integer 'Déclaration des variables
Dim r As Double
Dim V As Double 'Obligé en double ici, sinon avec certaines couleur le dégradé ce fai pas comme il faut
Dim b As Double
Dim r2 As Double
Dim v2 As Double
Dim b2 As Double
Dim decR As Double
Dim decV As Double
Dim decB As Double
Dim Scal As Byte
Dim Vcalc As Long

b = DebCol \ 65536 'Décomposition des couleur en rouge
V = (DebCol - b * 65536) \ 256 'Vert et bleu
r = DebCol - b * 65536 - V * 256 'calcul trouvé sur www.vbcode.com
b2 = FinCol \ 65536
v2 = (FinCol - b2 * 65536) \ 256
r2 = FinCol - b2 * 65536 - v2 * 256

Scal = Objet.ScaleMode 'Enregistre le scale de l'objet
Objet.ScaleMode = 3 'Modifi le scale de l'objet en pixel

If Vertical = False Then Vcalc = Objet.ScaleWidth Else Vcalc = Objet.ScaleHeight

decR = (r2 - r) / Vcalc 'Calcul du décalage des couleurs
decV = (v2 - V) / Vcalc
decB = (b2 - b) / Vcalc

'Tracage du dégradé
If Vertical = False Then 'Horizontal
For a = 0 To Objet.ScaleWidth
  Objet.Line (a, 0)-(a + 1, Objet.ScaleHeight), RGB(r, V, b), BF
  r = Abs(r + decR): V = Abs(V + decV): b = Abs(b + decB) 'Incrémentation des couleurs
Next a
Else 'Vertical
For a = 0 To Objet.ScaleHeight
Objet.Line (0, a)-(Objet.ScaleWidth, a + 1), RGB(r, V, b), BF
r = Abs(r + decR): V = Abs(V + decV): b = Abs(b + decB) 'Incrémentation des couleurs
Next a
End If
'J'utilise la valeur absolu ci-dessus car sur certines couleur ca passe en dessous de zéro :-( sais pas pk

Objet.ScaleMode = Scal 'Remet comme il faut le scale de l'objet
If Err Then Degrade = 1 Else Degrade = 0 'La fonction renvoi 1 en cas d'erreur
End Function

Private Sub Command1_Click()
Dim Vr1
Vr1 = Degrade(Form1, 1, 1000, 350)
End Sub