Effets de couleur dans une feuille (nouvelle version)

Soyez le premier à donner votre avis sur cette source.

Snippet vu 3 197 fois - Téléchargée 68 fois

Commenter

Contenu du snippet

Ce code est la réponse à la source de skyraider.
Je tiens à m'excuser auprès de Mr.X à qui j'ai volé sa fonction "Xwait", je dois avouer que je m'en sers tout le temps.
Pour ce qui est de la source, pour faciliter les changements, j'ai stocké toutes les informations dans des variables ( ce sont des tableaux de 3 colonnes, 1 par couleur rgb). Voilà. Ah oui, il vous faut créer un projet avec une feuille nommée Form1 et un bouton nommé Command1, pour un meilleur effet, mettez la valeur borderstyle de la feuille à 0. Double-cliquez n'importe où sur la feuille pour aficher en plein écran, allez avec la souris dans le coin inférieur droit pour afficher le bouton de sortie.
Puis mettez ce code dans le code de la feuille :

Source / Exemple : 


Private Declare Function GetTickCount Lib "kernel32" () As Long

Option Explicit

'voilà les variables en question
Dim Sens(1 To 3) As Boolean ' pour savoir si il faut ajouter ou soustraire
Dim Valeur(1 To 3) As Integer
Dim Increment(1 To 3) As Integer
Dim Plage(1 To 3, 1 To 2) As Integer ' la plage : 1 to 3 pour les couleurs (R,V ou B) et 1 to 2 Pour le maximum et le Minimum de l'incrément
Dim MaxValeur(1 To 3) As Integer 'les valeurs minimales et maximales des couleurs
Dim MinValeur(1 To 3) As Integer

Sub XWait(ByVal MilsecToWait As Long)
    Dim lngEndingTime As Long
  
    lngEndingTime = GetTickCount() + (MilsecToWait)
    Do While GetTickCount() < lngEndingTime
        DoEvents
    Loop
End Sub

Private Sub Command1_Click()
Unload Me
End
End Sub

Private Sub Form_DblClick()
Select Case Me.WindowState
    Case vbMaximized
        Me.BorderStyle = 2
        Me.WindowState = vbNormal
    Case vbNormal
        Me.BorderStyle = 0
        Me.WindowState = vbMaximized
End Select
Command1.Move Me.Width - Command1.Width, Me.Height - Command1.Height
End Sub

Private Sub Form_Load()
Me.Show 'ne pas oublier ça sinon la feuille ne s'affiche pas à cause de la boucle qui suit
Command1.Move Me.Width - Command1.Width, Me.Height - Command1.Height
Dim i
For i = 1 To 3
    Plage(i, 1) = 0
    Plage(i, 2) = 2
    MaxValeur(i) = 255
    MinValeur(i) = 0
Next

Do
    Coloriser
    XWait 10
    DoEvents
Loop
End Sub

Sub Coloriser()
On Error GoTo erreur:
Me.BackColor = RGB(Valeur(1), Valeur(2), Valeur(3))
Randomize Timer
Dim i
For i = 1 To 3
    Increment(i) = ((Plage(i, 2) - Plage(i, 1)) * Rnd) + Plage(i, 1)
        Select Case Sens(i)
            Case True
                If Valeur(i) + Increment(i) <= MaxValeur(i) Then
                    Valeur(i) = Valeur(i) + Increment(i)
                Else
                    Valeur(i) = MaxValeur(i)
                    Sens(i) = False
                End If
            Case False
                If Valeur(i) - Increment(i) >= MinValeur(i) Then
                    Valeur(i) = Valeur(i) - Increment(i)
                Else
                    Valeur(i) = MinValeur(i)
                    Sens(i) = True
                End If
        End Select
    DoEvents
Next i
erreur: If Err.Number <> 0 Then
    MsgBox "Une erreur de type " & Err.Number & " est apparue à " & Time & " dans le module " & Err.Source & vbCrLf & "Description : " & vbCrLf & "    " & Err.Description & vbCrLf & vbCrLf & "Pour consulter l'aide relative à cette erreur, allez dans " & Err.HelpFile & " (ce chemin sera enregistré dans le presse-papier)" & vbCrLf & vbCrLf & "L'application va se terminer", vbCritical, "ERREUR"
    Clipboard.Clear
    Clipboard.SetText Err.HelpFile
    If Err.Number = 5 Then MsgBox "Conseil : " & vbCrLf & "Il est probable que la Valeur Minimale d'une plage de couleur soit négative." & vbCrLf & "Ce qui entraînera systèmatiquement cette erreur (" & Err.Description & ")" & vbCrLf & "Pour remédier à ça, changez toutes les Valeurs Minimales en valeurs positives.", vbInformation, "Conseil"
    End
End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If X >= Me.Width - Command1.Width And Y >= Me.Height - Command1.Height Then
    Command1.Visible = True
Else
    Command1.Visible = False
End If
End Sub

Private Sub Form_Terminate()
End
End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub

Conclusion :


Ne pas mettre une valeur minimale de couleur négative. Celà entrainerait une erreur.
Bon, je sais que c'est laid, inutile et que ça rend épileptique mais bon... quand on a rien à faire...

A voir également

Ajouter un commentaire Commentaire
skyraider
9 mars 2001 à 19:03
Bien que je le trouve correct, je voulais savoir pourquoi tu cite au début : "Ce code est la réponse à la source de skyraider." ? Je ne t'ais jamais demandé quoique ce soit , alors pourquoi cette phrase ? Amicalement. Skyraider
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 (Whiterabbit83)