Crée un dégradé de couleur dans une fenêtre form

Télécharger le projet
Commenter

Description

Crée un dégradé de couleur dans une fenêtre Form
Je ne sais pas de qui est le code. Désoler.

Source / Exemple :

' Form

    'Les variables R1, G1 et B1 définissent les valeurs R, G et B de la couleur de départ
    'Les variables R2, G2 et B2 définissent les valeurs R, G et B de la couleur d'arrivée

Dim R1 As Integer
Dim R2 As Integer
Dim G1 As Integer
Dim G2 As Integer
Dim B1 As Integer
Dim B2 As Integer
    
    'La variable Comteur est la variable compteur des boucles For...Next

Dim Compteur As Integer
    
    'Les variables CouleurR, CouleurG et CouleurB contiendront les valeurs R,G,B de la couleur des lines déssinées.

Dim CouleurR As Single
Dim CouleurG As Single
Dim CouleurB As Single
    
    'Les variables difR, difG et difB représenteront la différence entre les valeurs R, G et B de la couleur du départ et celles de l'arrivé.
    
Dim difR As Integer
Dim difG As Integer
Dim difB As Integer
    
    'La variable TotalTour représente le nombre total de tours à effectuer dans les boucles For...Next

Dim TotalTour As Integer



Sub Fade(obj As Object, Optional vRed As Variant, _
         Optional vGreen As Variant, Optional vBlue As Variant, _
         Optional vVert As Variant, Optional vHoriz As Variant, _
         Optional vLightToDark As Variant, Optional vInverse As Variant)
    ' Donne des valeures par défaut aux paramètres optionnels
    If IsMissing(vRed) Then vRed = False
    If IsMissing(vBlue) Then vBlue = False
    If IsMissing(vGreen) Then vGreen = False
    If Not vRed And Not vGreen Then vBlue = True ' Une couleur est requise
    If IsMissing(vVert) Then vVert = False
    If IsMissing(vHoriz) Then vHoriz = Not vVert
    If IsMissing(vInverse) Then vInverse = False
    If Not vVert And Not vHoriz Then vHoriz = True ' Une orientation est
    If IsMissing(vLightToDark) Then vLightToDark = True

    ' Gestion des erreurs
    On Error Resume Next
    With obj
        'Sauve les propriétés
        Dim fAutoRedraw As Boolean, ordDrawStyle As Integer
        Dim ordDrawMode As Integer, iDrawWidth As Integer
        Dim ordScaleMode As Integer
        Dim rScaleWidth As Single, rScaleHeight As Single
        fAutoRedraw = .AutoRedraw: iDrawWidth = .DrawWidth
        ordDrawStyle = .DrawStyle: ordDrawMode = .DrawMode
        rScaleWidth = .ScaleWidth: rScaleHeight = .ScaleHeight
        ordScaleMode = .ScaleMode
        ' Une erreur est générée si une de ces propriété est manquante
        If Err Then Exit Sub
        On Error GoTo 0
        fAutoRedraw = .AutoRedraw

        ' On fixe les paramètres pour le dégradé
        .AutoRedraw = True
        .DrawWidth = 2
        .DrawStyle = vbInsideSolid: .DrawMode = vbCopyPen
        .ScaleMode = vbPixels
        .ScaleWidth = 256 * 2: .ScaleHeight = 256 * 2

        Dim clr As Long, i As Integer, X As Integer, Y As Integer, X2 As Integer, Y2 As Integer
        Dim iRed As Integer, iGreen As Integer, iBlue As Integer
         X2 = .ScaleWidth
            Y2 = .ScaleHeight
        For i = 0 To 255
            ' Fixe les couleurs des lignes
            If vLightToDark Then
                If vRed Then iRed = 255 - i
                If vBlue Then iBlue = 255 - i
                If vGreen Then iGreen = 255 - i
            Else
                If vRed Then iRed = i
                If vBlue Then iBlue = i
                If vGreen Then iGreen = i
            End If
            clr = RGB(iRed, iGreen, iBlue)
            ' Dessine chaque ligne
            If vHorizSpace > 0 Then
                obj.Line (0, Y + vHorizSpace)-(.ScaleWidth, Y + 2 + vHorizSpace), clr, BF
                Y = Y + 2
            GoTo passe
            End If
            If vInverse Then
            If vVert Then
                obj.Line (.ScaleWidth, Y2 - 2)-(Y2, 0), clr, BF
                Y2 = Y2 - 2
            End If
            If vHoriz Then
                obj.Line (X2 - 2, .ScaleHeight)-(X2, 0), clr, BF
                X2 = X2 - 2
            End If
            Else
            If vVert Then
                obj.Line (0, Y)-(.ScaleWidth, Y + 2), clr, BF
                Y = Y + 2
            End If
            If vHoriz Then
                obj.Line (X, 0)-(X + 2, .ScaleHeight), clr, BF
                X = X + 2
            End If
            End If
passe:
        Next
        ' Restore les propriétés précédentes
        .AutoRedraw = fAutoRedraw: .DrawWidth = iDrawWidth
        .DrawStyle = ordDrawStyle: .DrawMode = ordDrawMode
        .ScaleMode = ordScaleMode
        .ScaleWidth = rScaleWidth: .ScaleHeight = rScaleHeight
    End With
End Sub
Private Sub Command1_Click()

Dim Rouge As Boolean, Vert As Boolean, Bleu As Boolean, Horizontal As Boolean, Vertical As Boolean, ClairVersFonce As Boolean, Inverse As Boolean

Rouge = False
Vert = False
Bleu = False
Vertical = False
Horizontal = False
ClairVersFonce = False
Inverse = False

If Check1 = 1 Then Rouge = True
If Check2 = 1 Then Vert = True
If Check3 = 1 Then Bleu = True
If Check4 = 1 Then Vertical = True
If Check5 = 1 Then Horizontal = True
If Check6 = 1 Then ClairVersFonce = True
If Check7 = 1 Then Inverse = True


Fade Me, Rouge, Vert, Bleu, Vertical, Horizontal, ClairVersFonce, Inverse


End Sub


Private Sub Command2_Click()

'Interception des erreurs:

On Error Resume Next

    'Calcul des différences dentre les valeurs R, G et B des couleurs de départ et d'arriver.

difR = R2 - R1
difG = G2 - G1
difB = B2 - B1

    'Initialisation des Variables:

CouleurR = R1
CouleurG = G1
CouleurB = B1

    'Si le mode choisi est Horizontal:
    
If Horizontal.Value = True Then

    'La boucle doit s'éxécuter au temps de fois qu'il y a de pixels sur la hauteur de la fenêtre;
    'la propriété ScaleMode de la fenêtre doit être sur 3

    TotalTour = Me.ScaleHeight
        
     'Initialisation de la boucle; elle tracera suffisament de droite pour couvrir l'écran
             
        For Compteur = 1 To TotalTour
        
     'A chaque tour, la couleur doit être modifier; en partant de la couleur de départ, on doit
     'arriver à la couleur de fin au bout de "TotalTour" boucles. à chaque tour, on augmente donc
     'à chaque tour de (différence entre couleur de départ et couleur d'arriver) sur (Nombre de tours)
             
        CouleurR = CouleurR + (difR / TotalTour)
        CouleurG = CouleurG + (difG / TotalTour)
        CouleurB = CouleurB + (difB / TotalTour)
     
     'On trace une ligne touchant la précédente, et avec la couleur précédemment obtenue
        
        Me.Line (0, Compteur)-(Me.ScaleWidth, Compteur), RGB(CouleurR, CouleurG, CouleurB)
     
     'Retour de la boucle
    
    Next

End If

    'Si le mode choisi est Vertical:
    
    If Vertical.Value = True Then
       
    'La boucle doit s'éxécuter au temps de fois qu'il y a de pixels sur la largeure de la fenêtre;
    'la propriété ScaleMode de la fenêtre doit être sur 3
    
    TotalTour = Me.ScaleWidth
        
     'Initialisation de la boucle; elle tracera suffisament de droite pour couvrir l'écran
        
        For Compteur = 1 To TotalTour
        
     'A chaque tour, la couleur doit être modifier; en partant de la couleur de départ, on doit
     'arriver à la couleur de fin au bout de "TotalTour" boucles. On augmente donc
     'à chaque tour de (différence entre couleur de départ et couleur d'arriver) sur (Nombre de tours)
             
        CouleurR = CouleurR + (difR / TotalTour)
        CouleurG = CouleurG + (difG / TotalTour)
        CouleurB = CouleurB + (difB / TotalTour)
        
    'On trace une ligne touchant la précédente, et avec la couleur précédemment obtenue

        Me.Line (Compteur, 0)-(Compteur, Me.ScaleHeight), RGB(CouleurR, CouleurG, CouleurB)
        
    'Retour de la boucle
    
    Next
End If

    'Si le mode choisi est Diagonale Gauche Droite:

    If GaucheDroite.Value = True Then
    
    'La boucle doit s'éxécuter au temps de fois qu'il y a de pixels sur la diagonale de la fenêtre;
    'la propriété ScaleMode de la fenêtre doit être sur 3
    'Pour avoir le nombre de pixels sur la diagonale, il faut passer pas Pythagore et par une propriété de la diagonale d'un carré: un carré de coté C à une diagonale de longueur racine de 2 * C
    
    TotalTour = Sqr(2) * Sqr((Me.ScaleWidth * Me.ScaleWidth) + (Me.ScaleHeight * Me.ScaleHeight))
    
        For Compteur = 1 To TotalTour
        
     'A chaque tour, la couleur doit être modifier; en partant de la couleur de départ, on doit
     'arriver à la couleur de fin au bout de "TotalTour" boucles. On augmente donc
     'à chaque tour de (différence entre couleur de départ et couleur d'arriver) sur (Nombre de tours)
    
        CouleurR = CouleurR + (difR / TotalTour)
        CouleurG = CouleurG + (difG / TotalTour)
        CouleurB = CouleurB + (difB / TotalTour)
        
        'On trace une ligne touchant la précédente, et avec la couleur précédemment obtenue
        
         Me.Line (Compteur, 0)-(0, Compteur), RGB(CouleurR, CouleurG, CouleurB)
         
         
         
         
    Next
End If

    'Si le mode choisi est Diagonale Droite Gauche:
    
    If DroiteGauche.Value = True Then
    'La boucle doit s'éxécuter au temps de fois qu'il y a de pixels sur la diagonale de la fenêtre;
    'la propriété ScaleMode de la fenêtre doit être sur 3
    'Pour avoir le nombre de pixels sur la diagonale, il faut passer pas Pythagore et par une propriété de la diagonale d'un carré: un carré de coté C à une diagonale de longueur racine de 2 * C
    
   TotalTour = Sqr(2) * Sqr((Me.ScaleWidth * Me.ScaleWidth) + (Me.ScaleHeight * Me.ScaleHeight))
    
        For Compteur = 1 To TotalTour
     'A chaque tour, la couleur doit être modifier; en partant de la couleur de départ, on doit
     'arriver à la couleur de fin au bout de "TotalTour" boucles. On augmente donc
     'à chaque tour de (différence entre couleur de départ et couleur d'arriver) sur (Nombre de tours)
    
        CouleurR = CouleurR + (difR / TotalTour)
        CouleurG = CouleurG + (difG / TotalTour)
        CouleurB = CouleurB + (difB / TotalTour)
        
        'On trace une ligne touchant la précédente, et avec la couleur précédemment obtenue
        
        Me.Line (Me.ScaleWidth - Compteur, 0)-(Me.ScaleWidth, Compteur), RGB(CouleurR, CouleurG, CouleurB)
    
        'Retour de la boucle
    
    Next
End If


End Sub

Private Sub Couleur_Depart_Click()

On Error GoTo Erreur

Me.CommonDialog1.ShowColor

    'Cette algorithme transforme la valeur renvoyé par la boite de dialogue, en valeur RGB. en effet, la boite de dialogue
    'Renvoit le numéro de la couleur, et nous aurons besoin, par la suite, d'en avoire le code RGB. Il faut d'abbord
    'passer par le mode Héxadécimal en convertissant la valeur retourné en valeur héxadécimale, puis, en partant du principe
    'qu'une valeur de couleur Héxadécimale est de type:&HBBGGRR, on peut trouver la valeur R1 représentant la valeur R de la
    'Couleur, puis la valeur G1 représentant la valeur G de la Couleur, puis la valeur B1 représentant la valeur de G de la couleur.
    'Celà permet de converir ce code en RGB.

R1 = Val("&H" & (Right(Hex(CommonDialog1.Color), 2)))
If Len(Hex(CommonDialog1.Color)) >= 4 Then G1 = Val("&H" & (Mid(Hex(CommonDialog1.Color), (Len(Hex(CommonDialog1.Color))) - 3, 2)))
If Len(Hex(CommonDialog1.Color)) = 6 Then B1 = Val("&H" & Left(Hex(CommonDialog1.Color), 2))
    
    'l'arrière plan de l'image = la couleur renvoyé

Picture1.BackColor = CommonDialog1.Color
    
    'Interception des erreurs: si l'utilisateur appuie, dans la boite de dialogue, sur Annuler, étant donné que la propriété CancelError
    'de cette boite de dialogue est sur True, la boite de dialogue renvoie une erreur, qui est ici intercépté. si la prpriété CancelError
    'est sur false, si l'utilisateur appuie sur Annuler, la couleur renvoyé par la boite de dialogue est le noire.

Erreur:
If Err.Number = 32755 Then Exit Sub


End Sub
Private Sub Couleur_Arrive_Click()
    
    'détection d'erreur:

On Error GoTo Erreur
Me.CommonDialog1.ShowColor

    'Cette algorithme transforme la valeur renvoyé par la boite de dialogue, en valeur RGB. en effet, la boite de dialogue
    'Renvoit le numéro de la couleur, et nous aurons besoin, par la suite, d'en avoire le code RGB. Il faut d'abbord
    'passer par le mode Héxadécimal en convertissant la valeur retourné en valeur héxadécimale, puis, en partant du principe
    'qu'une valeur de couleur Héxadécimale est de type:&HBBGGRR, on peut trouver la valeur R1 représentant la valeur R de la
    'Couleur, puis la valeur G1 représentant la valeur G de la Couleur, puis la valeur B1 représentant la valeur de G de la couleur.
    'Celà permet de converir ce code en RGB.

R2 = Val("&H" & (Right(Hex(CommonDialog1.Color), 2)))
If Len(Hex(CommonDialog1.Color)) >= 4 Then G2 = Val("&H" & (Mid(Hex(CommonDialog1.Color), (Len(Hex(CommonDialog1.Color))) - 3, 2)))
If Len(Hex(CommonDialog1.Color)) = 6 Then B2 = Val("&H" & Left(Hex(CommonDialog1.Color), 2))
    
    'l'arrière plan de l'image = la couleur renvoyé

Picture2.BackColor = CommonDialog1.Color
    
    'Interception des erreurs: si l'utilisateur appuie, dans la boite de dialogue, sur Annuler, étant donné que la propriété CancelError
    'de cette boite de dialogue est sur True, la boite de dialogue renvoie une erreur, qui est ici intercépté. si la prpriété CancelError
    'est sur false, si l'utilisateur appuie sur Annuler, la couleur renvoyé par la boite de dialogue est le noire.

Erreur:
If Err.Number = 32755 Then Exit Sub

End Sub

Private Sub Form_Resize()

'Mettre ici le code de votre choix pour recréer le dégradé
'à chaque redimensionnement de la feuille


End Sub
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 (Scooby1)