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
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.