Visual Basic, VB6, VB.NET, VB 2005, VB CodeS-SourceS

CodeS-SourceS est hébergé par Frontier.fr

Ce site au démarrage

begin process at 2012 02 12 11:08:44

Accueil Codes Tutoriels Forum Livres Emploi Services Connexion

Trouver un code source :

dans

[ Dernières recherches ]

Accueil >

VBA

> UN COLOR PICKER SANS API ET UNIQUEMENT PAR CALCUL

UN COLOR PICKER SANS API ET UNIQUEMENT PAR CALCUL

Information sur la source

Note :
Aucune note

Catégorie :VBA Classé sous :Color Picker, Mire, couleur, noir-blanc, excel Niveau :Débutant Date de création :17/10/2008 Date de mise à jour :22/11/2008 16:56:20 Vu / téléchargé :4 117 / 285

Auteur : bigfish_le vrai

Ecrire un message privé

Commentaire sur cette source (3)

Ajouter un commentaire et/ou une note

Description

Cliquez pour voir la capture en taille normale

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

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

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

Fichier Zip

Les Membres Club peuvent télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !

Color_picker-v1.1.xls588 800 octets

Télécharger le zip

Historique

18 octobre 2008 01:04:49 :: Correction de quelques fautes d'orthograpes.
12 novembre 2008 19:05:32 :: - j'ai epuré le code de la partie de calcul des couleurs - le calcul se fait quelque soit la taille de la mire - j'ai ajouté la possibilité de figer les axes par pression des touches Shift(Y) ou Ctrl(X) lors du deplacement du curseur, ce qui permet par exemple de faire varier la couleur voulu entre le noir et le blanc. cette fonction ne fonctionne que sur la mire principale. - j'ai ajouté un zoom local qui permet d'affiner la recherche de couleur et qui fonctionne exactement comme la mire principale. - j'ai aussi amelioré la mire pour qu'elle colle un peu mieux aux couleurs calculées
22 novembre 2008 16:56:20 :: ... de la description

Sources du même auteur

MANIPULER LES FENETRES ENFANT D'EXCEL

UTILISER LES PROPRIÉTÉS PERSO D'UN DOCUMENT COMME PARAMETRES...

UNE BOITE DE MESSAGE (MSGBOX) QUI SE PREND POUR UN POPUP

INFO POINT DE COURBE DE GRAPHIQUE EXCEL, QUI FONCTIONNE COMM...

ÔTER LA PROTECTION D'UNE FEUILLE GRACE À UN BUG D'EXCEL

Toutes les sources de bigfish_le vrai

Sources de la même categorie

GESTION PERSONNEL par oudlarbi

CALENDRIER EN VBA POUR EXCEL 2010 par nounou94

MANIPULER LES FENETRES ENFANT D'EXCEL par bigfish_le vrai

COLLECTION ID par Le Pivert

VBA MASQUE DE SAISIE NUMÉRIQUE par acive

Toutes les sources de la catégorie VBA

Sources en rapport avec celle ci

LOGICIEL DE MÉMO (POST-IT) par VBmasterX

EXPORTER LES IMAGES DE WORD ET D' EXCEL par Le Pivert

MANIPULER LES FENETRES ENFANT D'EXCEL par bigfish_le vrai

MISE EN FORME CONDITIONNELLE POUR EXCEL par draluorg

FILTRER UNE COLONE EXCEL PAR COULEUR GRACE AU VB D'OFFICE par surfzoid

Commentaires et avis

Commentaire de PCPT le 17/10/2008 20:18:20 administrateur CS

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)

Commentaire de bigfish_le vrai le 17/10/2008 20:39:59

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

;)

Commentaire de Warny le 19/10/2008 20:19:57

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.

Ajouter un commentaire

Discussions en rapport avec ce code source dans le forum

Question de couleur à n'y rien comprendre [ par gsniper ] Salut TaTousUn ptit pb de couleur avec excel 2000 :With ThisWorkbook.ActiveSheet.Shapes.AddShape(...) .Fill.ForeColor.SchemeColor = Col...en pas à pa Couleur onglet feuille Excel [ par Baboune1 ] Salut,comment peut on modifier la couleur de l'onglet d'une feuille Excell avec VBA ou VB6 ?(je sais le faire via Excel) EXCEL [ par diablosv ] bonjourqqn pourrait me dire comment mettre du texte en couleur ds une cellule EXCELDim classeurxls As Workbookclasseurxls.ActiveSheet.Range("A" & lign EXCEL [ par diablosv ] bonjourqqn pourrait me dire comment mettre du texte en couleur ds une cellule EXCELDim classeurxls As Workbookclasseurxls.ActiveSheet.Range("A" & lign recherche d'1 cellule Excel / à sa couleur. Urgent!!!!! [ par pou ] je suis très grand débutant en VBA, et je cherche une portion de code permettant de trouver dans un tableau Excel une cellule en fonction de sa couleu Couleur cellule excel [ par Florian29 ] Salut !J'exporte des données depuis un tableau vb vers excell et je voudrais pouvoir mettre une couleur de fond sur les cellules excel (je veux choisi vba: Obtenir la couleur des points d'un graphique excel [ par darollinghobbit ] Bonjour,J'ai un formulaire access qui me permet de mettre à jour une feuille excel contenant un graphique. Sur ce formulaire, j'ai mis la possibilité condition sur une couleur dans macro excel [ par vbdebut ] Bonjour,j'aurai besoin d'un coup de main pour faire une macro excel.Je voudrais éxécuter un code si le texte écrit dans la cellule tant est noir. Merc CODE COULEUR CELLULE EXCEL [ par ALAINLUCIEN ] J'AI PERDU LA LISTE DES CODES COULEURS UTILISES POUR EXECUTER UNE MACROEX: code 10 pour le rouge les autres ??????????merci d'avance VBA Excel [ par toniovargas ] Bonjour, et merci pour toutes les informations (très utiles!!!). Je suis en train de faire un programme sous vba excel avec userform. Je renvoi c

Nos sponsors

Derniers Blogs

SESSION SILVERLIGHT 5 3D : SLIDES ET DEMOS par Groc

[TECHDAYS 2012] SESSION WEBMATRIX 2 : LE COUTEAU SUISSE GRATUIT POUR VOS DéVELOPPEMENTS WEB - SLIDES par gpommier

[SHAREPOINT] LES SESSIONS TECHDAYS 2012. par Patrick Guimonet

TECHDAYS PARIS 2012 : SESSION PLEINIèRE JOUR 3 par ROMELARD Fabrice

MISHRA READER : UN LECTEUR RSS TRèS ZUNE STYLE EN OPEN SOURCE ! par Vko

Forum

RE : UN NOM EGALE UNE COULEUR par ucfoutu

RE : UN NOM EGALE UNE COULEUR par mibri

RE : MACRO DE REPRISE DE SéLECTION MULTIPLE par ucfoutu

MISE à JOUR EN CASCADE (TABLES MèRE/FILLE) AVEC COLONNES AUTO-INCREMENTéS par BasicZx81

RE : MCISENDSTRING() JOUER PLUSIEURS FOIS LE MêME MORCEAUX par Allan007

Côté IT

Offres d'emploi

Formations Video

Appels d'offres

Passerelle Pericles sur site Joomla 17
Budget : 499€
Infogerance Serveur Debian Linux
Budget : 2 400€
Developpeur applications iphone - ipad - android
Budget : 800€

Logiciels

Tribler (2012)
TRIBLER (2012)

Tribler est un client pair à pair (P2P/Peer-to-Peer) open source avec la capacité de regarder des...

Cliquez pour télécharger Tribler
OneSwarm (2012)
ONESWARM (2012)

Le peer-to-peer qui protège votre vie privée, c'est OneSwarm. Ce logiciel de peer-to-peer crypté...

Cliquez pour télécharger OneSwarm
PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO (V8.4)
PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO (V8.4)

PONAMEDIA TV DEVIENS HELLLOOO FLASH LA TV SUR VOTRE ORDINATEUR. Toute une plateforme Multi...

Cliquez pour télécharger PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO
Academy System (17.2.1.0)
ACADEMY SYSTEM (17.2.1.0)

Logiciel de gestion des établissements. - élèves/étudiants (inscription, dossier, absence...) -...

Cliquez pour télécharger Academy System
Easy-Planning (1.0.0.1)
EASY-PLANNING (1.0.0.1)

Basé sur les mêmes principes que MyPlanning, Easy-Planning permet de créer des plannings sous la ...

Cliquez pour télécharger Easy-Planning