Dégradé d'une couleur a une autre (amélioré)

Télécharger le projet
Commenter

Description

Voici unu fonction pour faire un dégradé d'une couleur a une autre

Copier cette fonction dans votre programme et mettre :

- objet : picturebox, form, ...
- DebCol et FinCol : couleur de départ et d'arrivé
- Vertical : True pour tracer le dégradé verticalement (False horizontalement)

C tou simple !

Cette nouvelle version est parfaite
elle ne modifi aucune propriétés et les degradé sont correct avec n'import kel couleurs

Source / Exemple : 


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

Conclusion :


y'a un exemple dans le zip
voila
@+
fabs
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (fabiin)