BOITE COULEURS

Signaler
Messages postés
1835
Date d'inscription
vendredi 13 mai 2005
Statut
Membre
Dernière intervention
20 novembre 2013
-
Messages postés
7568
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 octobre 2021
-
Cette discussion concerne un article du site. Pour la consulter dans son contexte d'origine, cliquez sur le lien ci-dessous.

https://codes-sources.commentcamarche.net/source/48234-boite-couleurs

Messages postés
7568
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 octobre 2021
127
BIGFISH_LE VRAI
Ton code fonctionne très bien. J'ai réussi à résoudre le problème de l'ouverture consécutive des fichiers images avec "Image.Visible". Je ne sais pas si cela est très orthodoxe en programmation, mais ça marche. Ce qui donne ceci:
Private Sub CommandButton1_Click()
Set Img = Nothing
Set Prcs = Nothing

Clic = False '----> on stop la boucle
Image1.Visible = False'image invisible
'------ selection d'un fichier image -------
Fichier = Application.GetOpenFilename( _
"Fichiers Image (*.jpg;*.gif;*.png;*.tif;*.bmp),*.jpg;*.gif;*.png;*.tif;*.bmp")
If Fichier = False Then Exit Sub

Filtre = Right(Fichier, 4)

Set Prcs = New ImageProcess
Set Img = New ImageFile
Img.LoadFile Fichier
mise_A_Jour_Image
Extension = Right(Fichier, 4)
Image1.Visible = True'image visible
End Sub
Je vais faire une maj
Cela fait 2 fois que tu me sauves la mise, merci encore
@
Messages postés
7568
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 octobre 2021
127
Merci BIGFISH_LE VRAI pour ton intérêt et tes conseils.
Je vais essayé d'améliorer les points que tu m'as signalé.Pour ce qui est de la perte d'ouverture de l'image quand on clic sur l'image ou sur l'userForm, cela doit provenir de la DLL Windows Image Acquisition Bibliothèque v2.0, car quand on désactive le système de la souris pour accrocher les couleurs (demarrer) cela se produit quand même.
@+ Le Pivert
Messages postés
1835
Date d'inscription
vendredi 13 mai 2005
Statut
Membre
Dernière intervention
20 novembre 2013
10
A oui j'oubliais :

Concernanrt la mire j'aime pas la solution qui consiste a piquer les couleurs par detection de la couleur des pixcel d'une image. Car la precision depend grandement de la qualité de l'image et par exemple les blancs, les noirs sont loin d'etre de vrai blancs ou de vrais noirs. Il n'y a qu'a regarder le resultat donner par ta mire.

A+
Messages postés
1835
Date d'inscription
vendredi 13 mai 2005
Statut
Membre
Dernière intervention
20 novembre 2013
10
Salut,

Il y a un gros bug! au bout d'un moment j'obtient une erreur out of memory qui me met en vrac l'affichage d'excel!
Tellement en vrac quíl m'a fallut plusieurs tentatives pour voir le message d'erreur ! pas glop !!!

J'ai donc travaillé un peu sur le probleme et la conclusion ce trouve au niveau de la variable DeskHdc de recuperation du HDC.
C'est du au fait que tu boucles en remetant a jour cette variable a chaque passage.
Avec la tempo a 1" il faut un bon moment pour obtenir cette erreur mais avec un peu de patience tu l'auras. Sans la tempo il suffit d'1" a 2" pour l'obtenir.

Comment faire ?
Pas besoin de recupperer le handle de context d'affichage a chaque boucle une seule fois a l'initialisation de ta forme suffit.

Autre chose : Il faut virer cette tempo insuportable !!! C'est pas agreable du tout d'avoir a attendre 1" pour obtenir chaque couleur.

Si dessous la resolution du probleme + une solution sans tempo:

------------------------------------------------------------------------------------
Code du userform1 :

Option Explicit
Option Compare Text

'GetSysColor: permet de retrouver la valeur des couleurs système.
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Dim Tableau(1 To 3) As Long
Const COLOR_BACKGROUND = 1
Dim Prcs As ImageProcess
Dim Fichier As Variant
Dim Filtre As String, Extension As String
Private Sub CommandButton1_Click()
Set Img = Nothing
Set Prcs = Nothing

Clic = False ----> on stop la boucle
'------ selection d'un fichier image -------
Fichier = Application.GetOpenFilename( _
"Fichiers Image (*.jpg;*.gif;*.png;*.tif;*.bmp),*.jpg;*.gif;*.png;*.tif;*.bmp")
If Fichier = False Then Exit Sub

Filtre = Right(Fichier, 4)

Set Prcs = New ImageProcess
[A1] = Fichier 'inscrire le chemin du fichier sur la feuille 1
Set Img = New ImageFile
Img.LoadFile Fichier
mise_A_Jour_Image
Extension = Right(Fichier, 4)
[A1] = "" 'supprimer le chemin du fichier de la feuille 1
End Sub

Private Sub Image1_Click() 'permet de lancer la detection des couleurs
Clic = Not Clic 'bascule true/false qui active ou desactive la detection des couleurs
If Clic = True Then MiseAJour
End Sub

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Couleur
End Sub

Private Sub Image3_Click() 'permet de lancer la detection des couleurs
Clic = Not Clic 'bascule true/false qui active ou desactive la detection des couleurs
If Clic = True Then MiseAJour
End Sub

Private Sub Image3_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Couleur
End Sub

Private Sub ScrollBar1_Change()
TextBox3 = ScrollBar1.Value
TextBox1 = Val(TextBox1) - Tableau(1) + Val(ScrollBar1.Value)
Tableau(1) = ScrollBar1.Value
TextBox2 = "&H" & Hex(TextBox1)
Image2.BackColor = TextBox1
End Sub

Private Sub ScrollBar2_Change()
TextBox4 = ScrollBar2.Value
TextBox1 = Val(TextBox1) - (Tableau(2) * 256) + (Val(ScrollBar2.Value) * 256)
Tableau(2) = ScrollBar2.Value
TextBox2 = "&H" & Hex(TextBox1)
Image2.BackColor = TextBox1
End Sub

Private Sub ScrollBar3_Change()
TextBox5 = ScrollBar3.Value
TextBox1 = Val(TextBox1) - (Tableau(3) * 65536) + (Val(ScrollBar3) * 65536)
Tableau(3) = ScrollBar3.Value
TextBox2 = "&H" & Hex(TextBox1)
Image2.BackColor = TextBox1
End Sub

Private Sub TextBox3_Change()
On Error Resume Next
ScrollBar1.Value = TextBox3
End Sub

Private Sub TextBox4_Change()
On Error Resume Next
ScrollBar2.Value = TextBox4
End Sub

Private Sub TextBox5_Change()
On Error Resume Next
ScrollBar3.Value = TextBox5
End Sub

Private Sub UserForm_Click()
Clic = False
End Sub

Private Sub UserForm_Initialize()
'Initialise les contrôles avant d'afficher la boîte de dialogue
ScrollBar1.Value = 0
ScrollBar2.Value = 0
ScrollBar3.Value = 0
TextBox1 = 0
TextBox2 = "&H0"
Demarrer
End Sub
Private Sub Couleur()
Dim Rouge As Integer, Vert As Integer, Bleu As Integer
Dim Couleur As Long

On Error Resume Next

'----- Transforme les valeurs Long & Hex en code RGB -----
Couleur = TextBox1

Rouge = Int(Couleur Mod 256)
Vert = Int((Couleur Mod 65536) / 256)
Bleu = Int(Couleur / 65536)
'----------------------------------------------------------

Application.EnableEvents = False
TextBox3 = Rouge
TextBox4 = Vert
TextBox5 = Bleu
Application.EnableEvents = True
End Sub

Private Sub mise_A_Jour_Image()
Dim w As Integer, h As Integer

'------ affichage image--------------
w = Img.Width
h = Img.Height
Set Image1.Picture = Img.ARGBData.Picture(w, h)

While (Prcs.Filters.Count > 0)
Prcs.Filters.Remove 1
Wend

Prcs.Filters.Add Prcs.FilterInfos("Scale").FilterID

End Sub

'Evenement fermeture du UserForm
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
'Ferme (si nécessaire) le Timer de récupération des couleurs à l'emplacement de la souris,
'sinon la procédure continue à fonctionner, même après la fermeture du userForm

'la ligne suivante ne sert plus a rien sans le timer
'Application.OnTime EarliestTime:=Now + _
TimeValue("00:00:01"), Procedure:="MiseAJour", Schedule:=False

Clic = False
End Sub

------------------------------------------------------------------------------------

------------------------------------------------------------------------------------
Code du module2:

Option Explicit

'GetCursorPos: renvoie la position de la souris sur l'écran.
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'GetDC: Renvoie le Handle d'un Contexte d'Affichage hDC (Handle of Device Context)
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
'GetPixel: renvoie la couleur du pixel en fonction des coordonnées spécifiées (X et Y)
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, _
ByVal Y As Long) As Long

'Coordonnées d'un point de l'écran.
Type POINTAPI
X As Long
Y As Long
End Type

Public Cible As Boolean
Public Clic As Boolean ---> nouvelle variable qui sert a entrer ou sortir de la boucle Do/Loop
Private DeskHdc As Long

Public Function GetDcColor() As Double
'Dim DeskHdc As Long ---> est maintenant declarée en debut de module
Dim Pxy As POINTAPI

'GetDC(0): Pour récupérer le hDC de l'écran
'DeskHdc = GetDC(0) ----> voir sub demarrer
'Récupére la position du curseur de la souris
GetCursorPos Pxy
'La fonction renvoie la couleur à l'emplacement spécifié
GetDcColor = GetPixel(DeskHdc, Pxy.X, Pxy.Y)
End Function

Sub Demarrer()
'Timer qui va déclencher la récupération de la couleur à l'emplacement
'du curseur de la souris (toutes les secondes).
'Application.OnTime Now + TimeValue("0:0:01"), "MiseAJour" ---> a ne plus utiliser
DeskHdc = GetDC(0) 'une fois a l'initialisation suffit
End Sub

'Procédure déclenchée par le Timer, qui va permettre la mise à jour du Userform
'en fonction de la position de la souris.
Sub MiseAJour()
Do Until Clic = False
Dim Rouge As Integer, Vert As Integer, Bleu As Integer
Dim Couleur As Long

'affiche la couleur correspondant à l'emplacement du curseur de la souris
UserForm1.Image2.BackColor = "&H" & Hex(GetDcColor)
Couleur = UserForm1.Image2.BackColor

'--- Convertit la couleur au format RGB -------
Rouge = Int(Couleur Mod 256)
Vert = Int((Couleur Mod 65536) / 256)
Bleu = Int(Couleur / 65536)

'--- Affiche les codes RGB dans les TextBox -----
UserForm1.TextBox3 = Rouge
UserForm1.TextBox4 = Vert
UserForm1.TextBox5 = Bleu

'Call Demarrer ----> on boucle maintenant a l'aide du Do/Loop
DoEvents 'imperatif !!!
Loop
End Sub
------------------------------------------------------------------------------------

Comment ça marche ?
c'est tres simple un clic dans l'image ou dans la mire de couleurs lance le piquage de couleur, un clic dans l'image ou dans la mire ou dans le userform ou sur le bouton stop le piquage de couleur.

l'ideal maintenant serait d'utiliser une API pour detecter un clique quelque soit l'endroit ou il ai eu lieu.

Il reste un probleme sur le quel je n'ai pas travaillé qui est qu'apres avoir utilisé la fonction de piquage de couleur la recupperation d'une image est sans effet. Soit une image a deja été recuperée et il n'est plus possible de la remplacer soit aucune image n'a été récupérée et il n'est plus possible dans récupérée une. La boite de dialogue s'ouvre bien et permet bien de choisir une image mes elle n'est pas inserée dans le control image.

encore quelque petite choses a ameliorer mais dans l'ensemble c'est bien!

A+ :)