BOITE COULEURS

Commentaire de bigfish_le vrai le 16/10/2008 21:14:08

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+ :)

Commentaire de Le Pivert le 17/10/2008 08:04:29

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