Un color picker sans api et uniquement par calcul

Soyez le premier à donner votre avis sur cette source.

Vue 5 366 fois - Téléchargée 397 fois

Description

Certain diront : encore un color picker !
Oui ! Mais celui-ci n'utilise pas d'API pour récupérer la couleur d'un pixel.
Les couleurs sont calculées en fonction de la position du curseur sur la mire. La mire n'est en faite qu'une représentation de ce que l'on obtient par calcul.

Pourquoi cette méthode plutôt que les API ?
Le problème quand on utilise les API pour récupérer les couleurs d'une mire, qui n'est en faite qu'une image, est que la précision dépend de la qualité de l'image elle même. Par exemple une image peut avoir des blanc pas très blanc, c'est à dire contenant des traces de rouge ou autre. Avec la méthode que je propose ici la couleur récupérée est exact

Comment cela marche ?
Une fois le Userform ouvert cliquez sur la mire pour commencer puis cliquez de nouveau pour valider la couleur.

J'ai essayé d'expliquer au mieux le fonctionnement du code, mais suis conscient que ce n'est pas tres claire. Il faudra faire un petit effort pour comprendre et ne pas hesiter à poser des questions.

Remarque : mise à par la partie calcul le reste du code est peu optimisé. Le deplacement de la mire dans la frame pourrait etre amelioré par l'utilisation de la Function GetCursorPos de la library User32 en lieu et place de l'evenement mouse_move.
(peut etre dans une prochaine version)

Source / Exemple :


Dans le code de la forme :

'Code Créée par : BigFish_le Vrai (Philippe E)
'le :17-10-2008
'modifié le 12-11-2008
'V1.1
'
Option Explicit

Dim Clic As Boolean

Private Sub CheckBox1_Click()
' permet de basculer entre la mire de couleur et la mire noir et blanc
    With Me
        If .CheckBox1.Value = True Then
            .MireCouleur.Visible = False
            .MireCouleur.Enabled = False
            .MireNoirBlanc.Visible = True
            .MireNoirBlanc.Enabled = True
        Else
            .MireCouleur.Visible = True
            .MireCouleur.Enabled = True
            .MireNoirBlanc.Visible = False
            .MireNoirBlanc.Enabled = False
        End If
    End With
End Sub

Private Sub BoutonApply_Click()
    Red = TextBoxRed.Value
    Green = TextBoxGreen.Value
    Blue = TextBoxBlue.Value
    'MsgBox "red=" & Red & "  green=" & Green & "  blue=" & Blue
    ActiveWorkbook.Colors(25) = RGB(Red, Green, Blue)
    ActiveWorkbook.Colors(26) = RGB(255 - Red, 255 - Green, 255 - Blue)
End Sub

Private Sub BoutonClose_Click()
    Unload Me
End Sub

Private Sub Image1_Click()
    Clic = Not Clic 'bascule true/false
End Sub

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Clic = True Then
        Y = Y
        X = X
        Call ColorCalculation(X, Y)
        With Me
            .TextBoxRed.Value = Round(Red, 0)
            .ScrollBarRed.Value = Round(Red, 0)
            .TextBoxGreen.Value = Round(Green, 0)
            .ScrollBarGreen.Value = Round(Green, 0)
            .TextBoxBlue.Value = Round(Blue, 0)
            .ScrollBarBlue.Value = Round(Blue, 0)
            .LabelPrevisualisation.BackColor = RGB(Red, Green, Blue)
        End With
    End If
End Sub

Private Sub MireCouleur_Click()
    Clic = Not Clic 'bascule true/false
    With Me
        'on recupere les dernieres valeurs pour determiner la position de l'image dans la frame
        If Not .CheckBox2 Then 'si dynamic = false
            Call ImagePosition(KeepX, KeepY)
        End If
    End With
End Sub
Private Sub MireNoirBlanc_Click()
    Clic = Not Clic 'bascule true/false
End Sub

Private Sub MireCouleur_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Clic = True Then
        Y = (256 / Me.MireCouleur.Height) * Y
        X = (255 / Me.MireCouleur.Width) * X
        'calcul des couleurs par appel de la sub ColorCalculation
        Call ColorCalculation(X, Y)
        With Me
            If .CheckBox2 Then 'si dynamic = true
                If ShiftKeyStat = True Then 'permet de figer l'axe y
                    Y = KeepY
                Else
                    KeepY = Y
                End If
                If CtrlKeyStat = True Then 'permet de figer l'axe X
                    X = KeepX
                Else
                    KeepX = X
                End If
                Call ImagePosition(X, Y)
            End If
            .TextBoxRed.Value = Round(Red, 0)
            .ScrollBarRed.Value = Round(Red, 0)
            .TextBoxGreen.Value = Round(Green, 0)
            .ScrollBarGreen.Value = Round(Green, 0)
            .TextBoxBlue.Value = Round(Blue, 0)
            .ScrollBarBlue.Value = Round(Blue, 0)
            .LabelPrevisualisation.BackColor = RGB(Red, Green, Blue)
        End With
    End If
End Sub
Private Sub ImagePosition(ByVal X As Single, ByVal Y As Single)
    Dim Ximage As Long, Yimage As Long
    With Me
        .Frame1.SetFocus
        Ximage = -X + (.Frame1.Width / (2 * (.Frame1.Zoom / 100)))
        Yimage = -Y + (.Frame1.Height / (2 * (.Frame1.Zoom / 100)))
        
        'gestion coin haut gauche
        If Ximage > 0 Then Ximage = 0
        If Yimage > 0 Then Yimage = 0
        
        'gestion coin bas droit
        If Ximage < -.Image1.Width + .Frame1.Width / (.Frame1.Zoom / 100) Then Ximage = -.Image1.Width + .Frame1.Width / (.Frame1.Zoom / 100)
        If Yimage < -.Image1.Height + .Frame1.Height / (.Frame1.Zoom / 100) Then Yimage = -.Image1.Height + .Frame1.Height / (.Frame1.Zoom / 100)
        
        'position de l'image dans la frame
        .Image1.Move Ximage, Yimage
        DoEvents
    End With
End Sub
Private Sub MireNoirBlanc_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    'Mire noir et blanc
    Dim MyX As Single
    MyX = X
    If Clic = True Then
        If MyX > 255 Then MyX = 255
        Red = MyX
        Green = MyX
        Blue = MyX
        With Me
            .TextBoxRed.Value = Round(Red, 0)
            .ScrollBarRed.Value = Round(Red, 0)
            .TextBoxGreen.Value = Round(Green, 0)
            .ScrollBarGreen.Value = Round(Green, 0)
            .TextBoxBlue.Value = Round(Blue, 0)
            .ScrollBarBlue.Value = Round(Blue, 0)
            .LabelPrevisualisation.BackColor = RGB(Red, Green, Blue)
        End With
    End If
End Sub

Private Sub ScrollBarRed_Change()
    TextBoxRed.Value = ScrollBarRed.Value
    Red = ScrollBarRed
    Label1.ForeColor = RGB(Red, 0, 0)
    LabelPrevisualisation.BackColor = RGB(Red, Green, Blue)
End Sub

Private Sub ScrollBarGreen_Change()
    TextBoxGreen.Value = ScrollBarGreen.Value
    Green = ScrollBarGreen
    Label2.ForeColor = RGB(0, Green, 0)
    LabelPrevisualisation.BackColor = RGB(Red, Green, Blue)
End Sub

Private Sub ScrollBarBlue_Change()
    TextBoxBlue.Value = ScrollBarBlue.Value
    Blue = ScrollBarBlue
    Label3.ForeColor = RGB(0, 0, Blue)
    LabelPrevisualisation.BackColor = RGB(Red, Green, Blue)
End Sub

Private Sub TextBoxRed_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If TextBoxRed.Value > 255 Then
        TextBoxRed.Value = 255
    End If
    ScrollBarRed.Value = Round(Abs(TextBoxRed.Value), 0)
End Sub
Private Sub TextBoxGreen_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If TextBoxGreen.Value > 255 Then
        TextBoxGreen.Value = 255
    End If
    ScrollBarGreen.Value = Round(Abs(TextBoxGreen.Value), 0)
End Sub
Private Sub TextBoxBlue_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If TextBoxBlue.Value > 255 Then
        TextBoxBlue.Value = 255
    End If
    ScrollBarBlue.Value = Round(Abs(TextBoxBlue.Value), 0)
    TextBoxRed.SetFocus
End Sub

Private Sub TextBoxRed_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Clic = False
End Sub
Private Sub TextBoxGreen_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Clic = False
End Sub
Private Sub TextBoxBlue_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Clic = False
End Sub

Private Sub TextBoxScale_Change()
    Dim ZoomValue As Integer
    On Error Resume Next
    ZoomValue = CInt(Me.TextBoxScale.Value)
    If Err = 0 Then
        If ZoomValue >= 100 Then
            Me.Frame1.Zoom = Me.TextBoxScale.Value
        End If
    Else
        Me.TextBoxScale.Value = 100
    End If
End Sub

Private Sub UserForm_Click()
    Clic = False
End Sub

Private Sub UserForm_Initialize()
    Clic = False
    
    Call TakeColor
    With Me
        .TextBoxScale.Value = .Frame1.Zoom
        .LabelPrevisualisation.BackColor = RGB(Red, Green, Blue)
        .TextBoxRed.Value = Red
        .TextBoxGreen.Value = Green
        .TextBoxBlue.Value = Blue
        .ScrollBarRed.Value = Red
        .ScrollBarGreen.Value = Green
        .ScrollBarBlue.Value = Blue
    End With
End Sub
---------------------------------------------------------------------------------------------

---------------------------------------------------------------------------------------------
Dans le module 1:

'Code Créée par : BigFish_le Vrai (Philippe E)
'le :19-10-2008
'modifié le 12-11-2008
'V1.1
'
Option Explicit

'permet de détecter l'état des touches du clavier
Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Const VK_LSHIFT As Long = &HA0 'touche shift de Gauche
Private Const VK_CONTROL As Long = &H11 'touche Ctrl

Public Red As Single, Green As Single, Blue As Single, KeepX As Single, KeepY As Single
Dim couleur As Long

Sub TakeColor()
    couleur = Range("B10").Interior.Color
    Red = couleur Mod 256
    Green = Int(couleur / 256 ^ 1) Mod 256 'Application.MOD(Int((couleur) / 256), 256)
    Blue = Int(couleur / 256 ^ 2) Mod 256 'Application.Mod(Int((couleur) / 256 ^ 2), 256)
    'MsgBox "red=" & Red & "  green=" & Green & "  blue=" & Blue
End Sub

Sub start()
    Load ColorEditor
    ColorEditor.Show
End Sub

Function ShiftKeyStat() As Boolean
    'permet de détecter si les touches shift de droite ou de gauche sont enfoncées
    ShiftKeyStat = False 'remise a false avant vérif.
    If GetKeyState(VK_LSHIFT) < 0 Then ShiftKeyStat = True
End Function
Function CtrlKeyStat() As Boolean
    'permet de détecter si la touche Ctrl est enfoncée
    CtrlKeyStat = False 'remise a false avant vérif.
    If GetKeyState(VK_CONTROL) < 0 Then CtrlKeyStat = True
End Function
Sub ColorCalculation(ByVal X As Single, ByVal Y As Single, Optional Maxi As Single, Optional Mini As Single)
'Mire de couleur
    'le principe ici est de calculer la couleur en fonction de la position du curseur.
    'la mire n'est en faite qu'une representation de ce que l'on obtient par le calcul.
    'le point de depart est le point Maxi du rouge qui est au milieu(Y) et a gauche(X) de la mire
    'toute la dificulté ici est que le point de depart des couleurs(Maxi,0,0) n'est pas confondu avec
    'le point 0(x=0,Y=0) de l'image. De plus dans l'axe Y l'image a une hauteur quelconque.
    'A cause des Arrondies (fonction Round()) les decalages sont d'environs de 2 pixels d'ou les valeurs half-1 et 256
    'j'utiliserai "ligne mediane" ou "mediane" pour designer la ligne au milieu de la hauteur.
    '
    Dim Half As Single
    Maxi = 255
    Mini = 0
    
        'depuis le point de depart
        'une petite regle de trois pour la prise en compte de la hauteur et de la largeur de l'image
        'ce qui permet a partir d'ici de considerer que l'image fait Maxi pixels de hauteur et de largeur
        If Y > Maxi - 1 Then Y = Maxi
        If ShiftKeyStat = True Then 'permet de figer l'axe y
            Y = KeepY
        Else
            KeepY = Y
        End If
        
        If CtrlKeyStat = True Then 'permet de figer l'axe X
            X = KeepX
        Else
            KeepX = X
        End If
        Half = Maxi / 2
        Select Case X
        Case Mini To (Maxi / 6) 'du rouge au jaune
            'le rouge varie de 0 a Maxi du noir a ligne mediane. Il est maxi de la mediane au blanc et du rouge au jaune
            'le vert varie de 0 a Maxi du rouge au jaune. Il varie de sa valeur X*6 de la mediane au blanc.
            'Il varie de 0 a sa valeur X*6 du noir a ligne mediane
            'le bleu est inexistant de la mediane au noir et du rouge au jaune. Il varie de 0 a Maxi
            'de la mediane au blanc
            If X < 1 Then X = 0
            If Y < Half - 1 Then 'du noir a la mediane
                Red = Y * 2 'du noir a la mediane
            Else
                Red = Maxi 'de la mediane au blanc
            End If
            If Y >= Half Then 'de la mediane au blanc. Le rouge est au maxi
                If (Y - Half) * 2 > X * 6 Then
                    Green = (Y - Half) * 2 'de la mediane au blanc
                Else
                    Green = X * 6 'du noir a la mediane
                End If
                Blue = (Y - Half) * 2 'de la mediane au blanc
            Else
                If Y * 2 < X * 6 Then
                    Green = Y * 2 'du noir a la mediane
                Else
                    Green = X * 6 'jusqu'au blanc
                End If
                Blue = Mini
            End If
            
        Case Round((Maxi / 6), 0) To (Maxi / 3) 'du jaune au vert
            'le rouge varie de Maxi a 0 du jaune au vert. il varie de 0 a sa valeur ((Maxi / 6) - (X - (Maxi / 6))) * 6
            'du noir a la ligne mediane. Il varie de sa valeur ((Maxi / 6) - (X - (Maxi / 6))) * 6 du vert au blanc
            'le vert est maxi du jaune au vert et de la mediane au blanc. Il varie de 0 a Maxi du noir a la mediane
            'le bleu est inexistant du jaune au vert et du noir au vert. Il varie de 0 a Maxi
            'de la mediane au blanc
            If Y < Half - 1 Then
                Green = Y * 2 'du noir a la mediane
            Else
                Green = Maxi 'de la mediane au blanc
            End If
            If Y >= Half Then 'de la mediane au blanc. Le vert est au maxi
                If (Y - Half) * 2 > ((Maxi / 6) - (X - (Maxi / 6))) * 6 Then
                    Red = (Y - Half) * 2 'de la mediane au blanc
                Else
                    Red = ((Maxi / 6) - (X - (Maxi / 6))) * 6 'du noir a la mediane
                End If
                Blue = (Y - Half) * 2 'de la mediane au blanc
            Else
                If Y * 2 < ((Maxi / 6) - (X - (Maxi / 6))) * 6 Then
                    Red = Y * 2 'du noir a la mediane
                Else
                    Red = ((Maxi / 6) - (X - (Maxi / 6))) * 6 'jusqu'au blanc
                End If
                Blue = Mini
            End If
        
        'et ainsi de suite
        Case Round((Maxi / 3), 0) To (Maxi / 2) 'du vert au cyan
            If Y < Half - 1 Then
                Green = Y * 2
            Else
                Green = Maxi
            End If
            If Y >= Half Then
                Red = (Y - Half) * 2
                If (Y - Half) * 2 > (X - (Maxi / 3)) * 6 Then
                    Blue = (Y - Half) * 2
                Else
                    Blue = (X - (Maxi / 3)) * 6
                End If
            Else
                Red = Mini
                If Y * 2 < (X - (Maxi / 3)) * 6 Then
                    Blue = Y * 2
                Else
                    Blue = (X - (Maxi / 3)) * 6
                End If
            End If
            
        Case Round((Maxi / 2), 0) To (Maxi / 3) * 2 'du cyan au bleu
            If Y < Half - 1 Then
                Blue = Y * 2
            Else
                Blue = Maxi
            End If
            If Y >= Half Then
                Red = (Y - Half) * 2
                If (Y - Half) * 2 > (Half - (X - (Maxi / 6))) * 6 Then
                    Green = (Y - Half) * 2
                Else
                    Green = (Half - (X - (Maxi / 6))) * 6
                End If
            Else
                Red = Mini
                If Y * 2 < (Half - (X - (Maxi / 6))) * 6 Then
                    Green = Y * 2
                Else
                    Green = (Half - (X - (Maxi / 6))) * 6
                End If
            End If
            
        Case Round((Maxi / 3) * 2, 0) To (Maxi / 6) * 5 'du bleu au magenta
            If Y < Half - 1 Then
                Blue = Y * 2
            Else
                Blue = Maxi
            End If
            If Y >= Half Then
                If (Y - Half) * 2 > (X - ((Maxi / 3) * 2)) * 6 Then
                    Red = (Y - Half) * 2
                Else
                    Red = (X - ((Maxi / 3) * 2)) * 6
                End If
                Green = (Y - Half) * 2
            Else
                If Y * 2 < (X - ((Maxi / 3) * 2)) * 6 Then
                    Red = Y * 2
                Else
                    Red = (X - ((Maxi / 3) * 2)) * 6
                End If
                Green = Mini
            End If
            
        Case Round((Maxi / 6) * 5, 0) To Maxi 'du magenta au rouge
            If X > Maxi - 1 Then X = Maxi
            If Y < Half - 1 Then
                Red = Y * 2
            Else
                Red = Maxi
            End If
            If Y >= Half Then
                Green = (Y - Half) * 2
                If (Y - Half) * 2 > (((Maxi / 6) * 5) - (X - (Maxi / 6))) * 6 Then
                    Blue = (Y - Half) * 2
                Else
                    Blue = (((Maxi / 6) * 5) - (X - (Maxi / 6))) * 6
                End If
            Else
                Green = Mini
                If Y * 2 < (((Maxi / 6) * 5) - (X - (Maxi / 6))) * 6 Then
                    Blue = Y * 2
                Else
                    Blue = (((Maxi / 6) * 5) - (X - (Maxi / 6))) * 6
                End If
            End If
        End Select

End Sub

Le reste dans le Zip

Conclusion :


Cette source est une réponse, sous forme d'exemple, à d'autres sources du meme type mais qui utilise les API pour récupérer les couleurs.

Merci de votre visite.

3ddI7IHd

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

PCPT
Messages postés
13299
Date d'inscription
lundi 13 décembre 2004
Statut
Modérateur
Dernière intervention
3 février 2018
23 -
salut bigfish_le vrai,
mais un pixel reste un pixel...
un blanc pas pur ok mais pas 2 couleurs....
alors pourquoi ne pas simplement partir d'une bonne image et simplifier le tout?

(mis à part pour le côté "code différent" qui peut en effet être intéressant)
bigfish_le vrai
Messages postés
1839
Date d'inscription
vendredi 13 mai 2005
Statut
Membre
Dernière intervention
20 novembre 2013
8 -
Salut a tous,

PCPT: tu as resumé avec ta derniere phrase : mis à part pour le côté "code différent" qui peut en effet être intéressant.

effectivement il y avait une partie chalenge que je trouvais interessante et le fait de faire quelque chose de different etait une motivation supplementaire. j'aime bien me demarqué ^^. Et puis le fait de pouvoir dir : c'est possible!
Mais j'ai bien conscience que ce n'est pas une revolution mais une alternative.
Et puis vas savoir cela donnera peut etre des idées a d'autre !

Dans tous les cas je pense que je suis dans l'esprit CS et de la publication de source.

En tous cas je me suis fait plaisir a me triturer le cerveau pour trouver cette methode.

Mais je suis d'accord avec : pourquoi ne pas simplement partir d'une bonne image et simplifier le tout

;)
cs_Warny
Messages postés
478
Date d'inscription
mercredi 7 août 2002
Statut
Membre
Dernière intervention
10 juin 2015
-
Je vois un avantage non négligeable à ta méthode : obtenue par calcul signifie qu'elle est vectorielle et qu'on peut donc facilement la mettre à n'importe quelle échelle.

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.