Soyez le premier à donner votre avis sur cette source.
Vue 4 566 fois - Téléchargée 450 fois
' 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
DARK SIDIOUS
A partir d'un ocx que je livrerai bientot ici.
Sinon 9/10 car c'est bien pensé
Nisand-systems@wanadoo.fr
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.