Dégradés de pleins de couleurs très rapides - maj1

Soyez le premier à donner votre avis sur cette source.

Vue 6 625 fois - Téléchargée 528 fois

Description

Dans une source postée par Yoman64 sur les dégradés de couleurs, il y a eu un commentaire de je sais
plus qui qui montré comment faire des dégradés avec l'api GradientFill. Grâce à cette api on peut réalisé
des dégradés d'une couleur à l'autre très rapidement.

J'ai adapté ça pour faire des dégradés de plusieurs couleurs...

En fait il existé déjà une source de lightness1028 je crois qui faisait plusieurs couleurs
mais c'était très lent ( chez moi en tout cas )
Avec ce programme c'est instantaté, puisque vous pouvez changer les couleurs ( jusqu'à 70 couleurs
après le picturebox est trop petit ) avec une scrollBar et ça chnage en même temps que la Scroolbar..

La nouvel version permet d'insérer une couleur entre deux autre ,alors que précédement on ne pouvait que les ajouter à la fin.

Voyez la capture pour le résultat...

Source / Exemple :


'Pour la source mais à cause des objets voici le source de la feuille 
'Pour ceux qui aiment pas les zips ou la compile...
'Mais y a quand même le zip
'Copier ça dans un doc txt vide et renommer le en .frm

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmPrinc 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Dégradé"
   ClientHeight    =   6765
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4710
   Icon            =   "frmPrinc.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   451
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   314
   StartUpPosition =   3  'Windows Default
   Begin MSComDlg.CommonDialog cmDialPrinc 
      Left            =   0
      Top             =   0
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.OptionButton optSens 
      Caption         =   "Horizontal"
      Height          =   195
      Index           =   0
      Left            =   0
      TabIndex        =   0
      Top             =   2400
      Value           =   -1  'True
      Width           =   4575
   End
   Begin VB.OptionButton optSens 
      Caption         =   "Vertical"
      Height          =   195
      Index           =   1
      Left            =   0
      TabIndex        =   1
      Top             =   2640
      Width           =   4575
   End
   Begin VB.Frame framPrinc 
      Height          =   3855
      Left            =   30
      TabIndex        =   10
      Top             =   2880
      Width           =   4635
      Begin VB.CommandButton cmdInsert 
         Caption         =   "Insérer une couleur ici"
         Height          =   495
         Left            =   2400
         TabIndex        =   9
         Top             =   3240
         Width           =   2055
      End
      Begin VB.CommandButton cmdPlus 
         Caption         =   "+"
         Height          =   255
         Left            =   480
         TabIndex        =   4
         Top             =   360
         Width           =   255
      End
      Begin VB.CommandButton cmdMoins 
         Caption         =   "-"
         Height          =   255
         Left            =   240
         TabIndex        =   3
         Top             =   360
         Width           =   255
      End
      Begin VB.CommandButton cmdDelete 
         Caption         =   "Supprimer cette couleur"
         Height          =   495
         Left            =   120
         TabIndex        =   8
         Top             =   3240
         Width           =   2055
      End
      Begin VB.HScrollBar scrlHrzBlue 
         Height          =   255
         Left            =   240
         Max             =   255
         TabIndex        =   7
         Top             =   2280
         Width           =   4095
      End
      Begin VB.HScrollBar scrlHrzGreen 
         Height          =   255
         Left            =   240
         Max             =   255
         TabIndex        =   6
         Top             =   1680
         Width           =   4095
      End
      Begin VB.HScrollBar scrlHrzRed 
         Height          =   255
         Left            =   240
         Max             =   255
         TabIndex        =   5
         Top             =   1080
         Width           =   4095
      End
      Begin VB.Label lblSample 
         Height          =   495
         Left            =   240
         TabIndex        =   15
         ToolTipText     =   "Cliquez ici pour choisir une couleur..."
         Top             =   2640
         Width           =   4095
      End
      Begin VB.Label lblColor 
         Height          =   255
         Left            =   840
         TabIndex        =   14
         Top             =   405
         Width           =   1455
      End
      Begin VB.Label lblBlue 
         Caption         =   "Bleu"
         Height          =   255
         Index           =   0
         Left            =   240
         TabIndex        =   13
         Top             =   1980
         Width           =   1095
      End
      Begin VB.Label lblGreen 
         Caption         =   "Vert"
         Height          =   255
         Left            =   240
         TabIndex        =   12
         Top             =   1380
         Width           =   1095
      End
      Begin VB.Label lblRed 
         Caption         =   "Rouge"
         Height          =   255
         Left            =   240
         TabIndex        =   11
         Top             =   780
         Width           =   1215
      End
   End
   Begin VB.PictureBox picPrinc 
      Height          =   2295
      Left            =   0
      ScaleHeight     =   2235
      ScaleWidth      =   4635
      TabIndex        =   2
      Top             =   0
      Width           =   4695
   End
End
Attribute VB_Name = "frmPrinc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function GradientFill Lib "msimg32" (ByVal Desthdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As Any, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Boolean

Private Type TRIVERTEX
    X As Long
    Y As Long
    Red As Integer
    Green As Integer
    Blue As Integer
    Alpha As Integer
End Type

Private Type Couleur
    Red As Integer
    Green As Integer
    Blue As Integer
End Type

Private Type GRADIENT_RECT
    UpperLeft As Long
    LowerRight As Long
End Type

Private Const GRADIENT_FILL_RECT_H = 0
Private Const GRADIENT_FILL_RECT_V = 1

Dim couleurActuelle As Integer
Dim Couleur() As Couleur
Dim couleurs() As TRIVERTEX

Private Sub colorisemoitoutca()

    Dim gRect As GRADIENT_RECT
    Dim sens As Integer
    Dim i As Integer
    Dim nbreTotalDeCouleurs As Integer
    
    nbreTotalDeCouleurs = UBound(Couleur)

    ReDim couleurs(nbreTotalDeCouleurs) As TRIVERTEX
    
    
    gRect.UpperLeft = 0
    gRect.LowerRight = 1
    
    If optSens(1).Value = True Then
    
        For i = 0 To nbreTotalDeCouleurs - 1
            
            If i >= nbreTotalDeCouleurs - 1 Then Exit For
    
            couleurs(i).X = 0
            couleurs(i).Y = i * (picPrinc.Height / (nbreTotalDeCouleurs - 1))
            couleurs(i).Alpha = 0
            couleurs(i).Red = "&H" & Hex(Couleur(i).Red / 16 * 256 * 16)
            couleurs(i).Green = "&H" & Hex(Couleur(i).Green / 16 * 256 * 16)
            couleurs(i).Blue = "&H" & Hex(Couleur(i).Blue / 16 * 256 * 16)
            
            couleurs(i + 1).X = picPrinc.Width
            couleurs(i + 1).Y = (i + 1) * (picPrinc.Height / (nbreTotalDeCouleurs - 1))
            couleurs(i + 1).Alpha = 0
            couleurs(i + 1).Red = "&H" & Hex(Couleur(i + 1).Red / 16 * 256 * 16)
            couleurs(i + 1).Green = "&H" & Hex(Couleur(i + 1).Green / 16 * 256 * 16)
            couleurs(i + 1).Blue = "&H" & Hex(Couleur(i + 1).Blue / 16 * 256 * 16)
            
            If GradientFill(picPrinc.hDC, couleurs(i), 2, gRect, 1, GRADIENT_FILL_RECT_V) = False Then MsgBox "Une erreur s'est produite...", vbCritical, "Oh..."
            
        Next i
        
    Else
        
        For i = 0 To nbreTotalDeCouleurs - 1
            
            If i >= nbreTotalDeCouleurs - 1 Then Exit For
    
            couleurs(i).X = i * (picPrinc.Width / (nbreTotalDeCouleurs - 1))
            couleurs(i).Y = 0
            couleurs(i).Alpha = 0
            couleurs(i).Red = "&H" & Hex(Couleur(i).Red / 16 * 256 * 16)
            couleurs(i).Green = "&H" & Hex(Couleur(i).Green / 16 * 256 * 16)
            couleurs(i).Blue = "&H" & Hex(Couleur(i).Blue / 16 * 256 * 16)
            
            couleurs(i + 1).X = (i + 1) * (picPrinc.Width / (nbreTotalDeCouleurs - 1))
            couleurs(i + 1).Y = picPrinc.Height
            couleurs(i + 1).Alpha = 0
            couleurs(i + 1).Red = "&H" & Hex(Couleur(i + 1).Red / 16 * 256 * 16)
            couleurs(i + 1).Green = "&H" & Hex(Couleur(i + 1).Green / 16 * 256 * 16)
            couleurs(i + 1).Blue = "&H" & Hex(Couleur(i + 1).Blue / 16 * 256 * 16)
            
            If GradientFill(picPrinc.hDC, couleurs(i), 2, gRect, 1, GRADIENT_FILL_RECT_H) = False Then MsgBox "Une erreur s'est produite...", vbCritical, "Oh..."
            
        Next i
        
    End If
    
    

    
End Sub

Private Sub cmdDelete_Click()
    
    Dim i As Integer
    
    If UBound(Couleur) = 2 Then MsgBox "Vous ne pouvez pas supprimer une couleur lorsque seules deux couleurs sont définies.", vbInformation, "Erreur...": Exit Sub
       
    For i = couleurActuelle To UBound(Couleur) - 1
    
        Couleur(i).Red = Couleur(i + 1).Red
        Couleur(i).Green = Couleur(i + 1).Green
        Couleur(i).Blue = Couleur(i + 1).Blue
        
    Next i
    
    ReDim Preserve Couleur(UBound(Couleur) - 1)
    
    If couleurActuelle = UBound(Couleur) Then couleurActuelle = couleurActuelle - 1
    
    lblColor.Caption = "Couleur " & couleurActuelle + 1 & "/" & UBound(Couleur)
    
    initScrl

End Sub

Private Sub cmdInsert_Click()

    Dim i As Integer
       
    ReDim Preserve Couleur(UBound(Couleur) + 1)
       
    For i = UBound(Couleur) To couleurActuelle + 1 Step -1
    
        Couleur(i).Red = Couleur(i - 1).Red
        Couleur(i).Green = Couleur(i - 1).Green
        Couleur(i).Blue = Couleur(i - 1).Blue
        
    Next i
    
    Couleur(couleurActuelle).Red = 0
    Couleur(couleurActuelle).Green = 0
    Couleur(couleurActuelle).Blue = 0
    
    lblColor.Caption = "Couleur " & couleurActuelle + 1 & "/" & UBound(Couleur)
    
    initScrl

End Sub

Private Sub cmdMoins_Click()

    couleurActuelle = couleurActuelle - 1
    
    If couleurActuelle < 0 Then couleurActuelle = 0
    
    lblColor.Caption = "Couleur " & couleurActuelle + 1 & "/" & UBound(Couleur)

    initScrl

End Sub

Private Sub cmdPlus_Click()

    couleurActuelle = couleurActuelle + 1
    
    If couleurActuelle > UBound(Couleur) - 1 Then
    
        ReDim Preserve Couleur(UBound(Couleur) + 1)
        Couleur(UBound(Couleur)).Red = 0
        Couleur(UBound(Couleur)).Green = 0
        Couleur(UBound(Couleur)).Blue = 0
        lblColor.Caption = "Couleur " & couleurActuelle + 1 & "/" & UBound(Couleur)
        
    Else
    
        lblColor.Caption = "Couleur " & couleurActuelle + 1 & "/" & UBound(Couleur)
        
    End If
    
    initScrl
    
End Sub

Private Sub initScrl()

    scrlHrzRed.Value = Couleur(couleurActuelle).Red
    scrlHrzGreen = Couleur(couleurActuelle).Green
    scrlHrzBlue = Couleur(couleurActuelle).Blue
    
    lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value)
    
    colorisemoitoutca

End Sub

Private Sub Form_Load()
    
    ReDim Couleur(2) As Couleur
    
    
    Couleur(0).Red = 0
    Couleur(0).Green = 0
    Couleur(0).Blue = 0
    
    Couleur(1).Red = 255
    Couleur(1).Green = 255
    Couleur(1).Blue = 255
    
    couleurActuelle = 0
    
    lblColor.Caption = "Couleur " & couleurActuelle + 1 & "/" & UBound(Couleur)
    
    initScrl
    
End Sub

Private Sub lblSample_Click()

    Dim laCouleur As Long
    
    cmDialPrinc.ShowColor
    laCouleur = cmDialPrinc.Color
    lblSample.BackColor = laCouleur
    
    scrlHrzRed.Value = Int(laCouleur And &HFF)
    scrlHrzGreen.Value = Int((laCouleur And &H100FF00) / &H100)
    scrlHrzBlue.Value = Int((laCouleur And &HFF0000) / &H10000)
    
End Sub

Private Sub optSens_Click(index As Integer)

    colorisemoitoutca

End Sub

Private Sub picPrinc_Paint()

    colorisemoitoutca
     
End Sub

Private Sub scrlHrzBlue_Change()

    Couleur(couleurActuelle).Blue = scrlHrzBlue.Value
    lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value)
    colorisemoitoutca

End Sub

Private Sub scrlHrzBlue_Scroll()

    Couleur(couleurActuelle).Blue = scrlHrzBlue.Value
    lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value)
    colorisemoitoutca

End Sub

Private Sub scrlHrzGreen_Change()

    Couleur(couleurActuelle).Green = scrlHrzGreen.Value
    lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value)
    colorisemoitoutca

End Sub

Private Sub scrlHrzGreen_Scroll()

    Couleur(couleurActuelle).Green = scrlHrzGreen.Value
    lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value)
    colorisemoitoutca

End Sub

Private Sub scrlHrzRed_Change()

    Couleur(couleurActuelle).Red = scrlHrzRed.Value
    lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value)
    colorisemoitoutca

End Sub

Private Sub scrlHrzRed_Scroll()
    
    Couleur(couleurActuelle).Red = scrlHrzRed.Value
    lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value)
    colorisemoitoutca

End Sub

Conclusion :


Et soyez sympa de laisser des commentaires...

Codes Sources

A voir également

Ajouter un commentaire Commentaire
Messages postés
132
Date d'inscription
samedi 25 mai 2002
Statut
Membre
Dernière intervention
31 août 2007

ben c'est moi qui ai parlé de ça effectivement et qui ai montré un bout de code... je vais voir ce que ça donne parce que les couleurs j'aime bien ça...

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.