Couleur "Long" en Binaire avec 24 bits
Bonjour,
je cherche à trouver une fonction rapide qui me transformerait une valeur longue de couleur en valeur binaire de 24 bits afin de modifier mon arbre de comptage de couleur. En effet, j'ai réussi à faire un arbre pour compter les couleurs uniques sur une zone de feuille Excel, mais ce dernier bute sur l'erreur de pile car sa "profondeur" au vu de son fonctionnement est trop grande...
Mon idée est alors de transformer les couleurs longues en binaire et mon arbre aura donc une profondeur de 25 (24 pour les fils/père + 1 du père originale) ce qui devrait passer en itération.
Je joints mon fichier de recherche qui peut également expliquer le fonctionnement d'un arbre pour ce genre de comptage. Il est commenté.
Sur le net je n'ai pas vraiment trouvé de fichier et explications suffisamment "simple" pour que je comprenne ! Le ChatGPT m'a permis de "comprendre" le principe et j'ai réussi à transposer ma compréhension en code...
Ce principe avec les couleurs en chaine de 1 et de 0, devrait donner un bon résultat même sur de grande image...
Le Fichier :
@ bientôt
LouReeD
Bonsoir LouReed
ROR n'existe pas en VBA mais tu as la fonction excel BITDECALD()
Je ferai ainsi :
Sub test()
Dim n As Long, i As Long, b As Integer
n = 123456789
For i = 1 To 24
b = n And 1 ' extraction bit poid faible
Debug.Print b ' visu
n = Application.WorksheetFunction.Bitrshift(n, 1) ' ROR (rotation droite)
Next i
End Subtu peux aussi extraire octet par octet avec un AND FF et en décalant de 8 bits (2nd paramètre) ensuite, si ça t'arrange pour des opérations intermédiaires.
Lire ensuite les 8 bits des octets
eric
Alors j'ai trouvé une fonction "double" qui transforme le "Long" en "Hexa" avec la fonction VBA Hex(), puis en binaire avec un select Case sur les 6 caractères Hexadécimal.
Pour une couleur j'obtiens donc une série de 1 et de 0 : 10001010 11101111 00100101, ensuite là je ne sais comment prendre le problème...
avec un1 en premier je dois me déplacer dans mon arbre sur le fils de droite, ensuite je prend son fils de gauche, et encore à gauche et encore une fois à gauche, puis à droite etc... Si je retombe sur cette couleur, alors s'il y a une valeur en "position" 24, c'est que cette couleur à déjà était comptabilisée, si le dernier nœud ou un nœud intermédiaire se trouve être vide c'est que nous avons une nouvelle couleur. mais contrairement à mon arbre en "Long" je ne dois pas m'arrêter au premier nœud vide, car je dois inscrire la couleur "en entier".
Donc une boucle de 24, où à chaque tour je contrôle si le fils de droite (1) est vide ou plein : si vide nouvelle couleur, j'incrément NbCoulUnique, mais je continue la boucle pour remplir les nœuds inférieur sans contrôle pour aller plus vite.
Je vais y réfléchir encore...
@ bientôt
LouReeD
Bonsoir,
Merci eriiic !
Bon avec votre code si je met 16 777 256 je n'obtiens pas le 11111111 11111111 11111111. Pour 255 j'ai bien le 11111111 00000000 00000000.
Sinon j'ai essayé de faire la boucle dont je parlais avec l'incrément du nombre de couleur si on inscrit une valeur sur le nœud et que sa position est égale à 24.
Mais il me manque des couleurs... L'image en comporte 9025, et là j'en trouve 7392...
Le fichier :
Bon c'est déjà bien je trouve, il me faut essayer sur des images plus grandes afin de voir s'il y a un problème de pile... Mais avec 24 itérations maximum par branche je pense que cela devrait passer.
@ bientôt
LouReeD
Bonsoir,
16777256 en hexa donne 1000028, pourquoi voudrais-tu qu'il ne donne que des 1 ?
Tu as dû te faire des noeuds
Par contre 2^24-1 = 16777215 donne bien 24 1
Je pense que le principe est bon pour avoir le résultat en binaire comme demandé.
Sinon tu peux augmenter la taille de la pile.
Tout dépend si ce n'est que pour toi parce qu'il faut intervenir sur le registre et adieu la portabilité
eric
Bonsoir,
en effet je mis perd... et vous parlez d'Hexa, je souhaite du binaire.
Pour moi Couleur long = couleur RGB avec RGB allant de 0 à 255 donc en binaire j'ai trois fois 8 bit : 11111111 pour le rouge, 00000000 pour le vert mais "éteint" et 00000000 pour le bleu éteint. Donc le rouge "pur" = 11111111 00000000 00000000, j'ai donc l'équivalent pour mon arbre d'une profondeur de 24, si le chemin entier des "24 nœuds" est rempli alors la couleur est déjà trouvée, s'il n'est pas rempli alors on le rempli et c'est une nouvelle couleur.
J'ai trouvé une fonction qui code le "Long" en 24 bit.
J'ai ma boucle de contrôle de l'arbre qui à l'air de fonctionner, mais je ne la trouve pas rapide, il est vrai également que je teste des couleurs sur des cellules alors les accès feuilles ralentissent la procédure, il faudrait presque pour les test que je crée un tableau 2D des cellules et lancer le chrono qu'à partir du moment où je scanne ce tableau. En effet, le but à l'issue est de travailler l'image en mémoire avec GetPixel.
L'autre soucis c'est que l'image testée à pour mon application Mosaïque 9025 couleurs uniques (en 0.82 seconde), pour IrFanView il y en a 9031 (instantané !), et ma boucle d'arbre binaire en trouve 7389 (en 0.4 seconde avec l'image en tableau VBA) !
Il doit y avoir une erreur sur les itérations...
Sinon j'ai ajouté des tests de couleurs identiques afin d'aller renseigner ou cherche dans l'arbre qu'une fois par lot de couleur identiques.
Le fichier en cours de recherche :
@ bientôt
LouReeD
Bonjour,
je parle en hexa car ça se converti facilement de tête en binaire et c'est plus court d'écrire et de lire FFF que 24 bits mais on parle bien de binaire.
Mais tu fais un arbre par exercice ou autre but ?
Pour avoir le nombre de couleurs avec un dict c'est 5 fois plus rapide :
Sub compte2()
Dim X As Long, Y As Long, Durée, X2 As Long, Y2 As Long
Dim dict
Set dict = CreateObject("Scripting.Dictionary")
' création d el'image pour travailler en mémoire
For X = 1 To 127
For Y = 1 To 127
Limage(X, Y) = Cells(X, Y).Interior.Color
Next Y
Next X
'début du timer
Durée = Timer
For X = 1 To 127
For Y = 1 To 127
dict(Limage(X, Y)) = Limage(X, Y)
Next Y
Next X
Debug.Print dict.Count & " en " & Format(Timer - Durée, "0.00") & " secondes"
End Subj'ai fait une 2nde boucle pour pouvoir comparer les temps. En mettant la construction du dict dans la 1ère il y aura encore un gain.
Perso j'en trouve 9024.
Ta version Compte m'annonce 9025 ce qui est comparable, et non 7389. Peut-être que je n'ai pas compris un truc
Il y a peut-être une perte de couleurs avec l'intégration de l'image dans excel (?)
eric
Bonjour
En fait j'essaie d'améliorer mon application Mosaique.
Genèse : utilisation d'un dico pour les couleurs unique, mais il y avait une lenteur sur de grandes images avec plus de 200000 couleurs différentes. (ce point mérite d'être retester car à l'époque il y avait un DoEvents dans la boucle ce qui ralentissait cette dernière)
Maintenant l'application emporte une boucle avec un tableau à 3 index de 0 à 255 et les couleurs sont transformées en RGB. Si le Tablo(R, G, B) =True alors couleur déjà trouvée sinon nouvelle couleur unique. C'est rapide !
Suite à navigation internet j'ai pu lire que "l'arbre" peut être très rapide, pour une image de 1024x768 avec près de 100000 couleurs il est à 1300ms, mais le code est en Delphi (je crois). D'où mon idée de faire un arbre binaire pour voir le gain de temps éventuel.
Mais comme dit plus haut il me faut refaire le test du dico sans les DoEvents, sait on jamais...
Pour mon codage en "binaire" ce que je ne comprend pas c'est la différence de nombre de couleur... Le code parait fonctionner mais il en manque.
Le résultat de Compte me parait être le "vrai".
Je continue de chercher.
@ bientôt
LouReeD
Bonjour LouReed, Eriiic,
je cherche à trouver une fonction rapide qui me transformerait une valeur longue de couleur en valeur binaire de 24 bits
Avec la fonction ConvLongToBin inclus dans le classeur ci-dessous.
Voir principe en détails en haut de la Feuil1.
Et la fonction en bas de cette même feuille.
Bonjour X Cellus,
votre fonction m'est simple à comprendre.
Il va falloir que je fasse un test de rapidité entre celle que j'ai trouvé, celle d'eriiic et la votre.
Sinon eriiic j'ai fais un test de rapidité de compte avec un dico (sans mettre de DoEvents
' on boucle sur les X
For I = 0 To Max_X
' on boucle sur les Y
For J = 0 To Max_Y
' on récupère la couleur du pixel testé
Coul = GetPixel(ImgEcran_Hdc, J, I + Décalage)
' s'il y a bien une couleur
If Coul > 0 Then
' on rempli le tableau des valeurs des couleurs d'origines
TabCoul(I, J) = Coul
' on décompose cette couleur
R = Int(Coul Mod 256)
V = Int((Coul Mod 65536) / 256)
B = Int(Coul / 65536)
' on accumule les couleurs uniques
If RVB(R, V, B) = False Then RVB(R, V, B) = True: NbCoul = NbCoul + 1
End If
Next J
Next Iil faut 10 secondes...(édit du 29/01/2023 : après de nouveaux test c'est plutôt de l'ordre des 5 secondes...) Et suite à des lectures internet (comme dit plus haut), cela devrait aller encore plus vite avec un arbre binaire...
oui on peut dire que c'est un exercice, mais pour moi c'est un peu plus : c'est optimiser encore un peu mon application Mosaïque.
l'image des tests :
Il me reste le problème du parcours et du compte des couleur dans l'arbre binaire, car là dessus j'ai un "gros" problème avec mes normalement 9025 couleur et 7389 !
Pourtant il me semble que les "rotations" sont bonnes...
Merci @ vous deux, je clôture ce fil pour ce qui est de la demande initiale : transformer une couleur "longue" en "binaire" sur 24 bits par groupe de valeur "RGB".
je reviendrais avec les résultats de vitesse des trois fonction "mise en binaire" !
@ bientôt
LouReeD
A nouveau,
je reviendrais avec les résultats de vitesse des trois fonction "mise en binaire" !
Donc, j'ai fait un peu de Tuning
Public Function ConvLongToBin(CodeLong As Double) As String
On Error GoTo ErrConv
For C = 1 To 3
BinRGB = Choose(C, Int(CodeLong Mod 256), Int((CodeLong Mod 65536) / 256), Int(CodeLong / 65536))
ConvLongToBin = ConvLongToBin & WorksheetFunction.Dec2Bin(BinRGB, 8)
Next C
Exit Function
ErrConv:
MsgBox "Une erreur est survenue entre la conversion du format type ""LONG"" vers la composition RGB.", vbCritical, "Erreur fatale"
End FunctionA +
Vous avez bien fait !
La fonction que j'ai trouvée sur une boucle de 2000 transformation est aussi rapide que la votre (tout dépend de "l'occupation du processeur je pense), quant à la fonction d'eriiic je n'ai pas réussi à la faire fonctionner...
Par contre cette "compétition" m'a permis de voir que les résultat sont erronés ! Vous connaissant je part donc sur le principe que vos données sont les bonnes !
Ce qui me met en tête que le décalage de compte sur mon image vient peut-être de là ! Je vais donc vérifier ce point !
Le fichier de test :
Je m'en retourne pour tester votre nouvel fonction X Cellus !
@ bientôt
LouReeD
Après quelques tests de vitesse votre deuxième fonction est entre 4 et 6 centième plus rapide !
Il me reste à tester ma boucle de compte de couleur !
@ bientôt
LouReeD
Bon et bien une fois encore X Cellus : Merci !
L'erreur de compte venait bien de ma fonction binaire. Une fois la vôtre mise en place je suis sur 9022 couleurs différentes sur mon fichier et ceci en moins d'une secondes !
Je vais de ce pas tester sur Mosaïque afin de le faire sur une grande image !
@ bientôt
LouReeD
Bon ben un peu déçu ! Je suis à 50 secondes ! mais ce doit être du à une mauvaise programmation, je n'ai pas d'autre explication !
Pour le moment le système d'un tableau à trois index correspondant aux composante de RGB avec 256 index chacun est plus rapide, sur cette image 5x plus rapide...
Faut que je regarde mieux "les cours" sur les arbres, car en Delphi, sortir presque 100000 couleurs uniques en 300 ms... C'est mon arbre et les recherche dedans qui doit poser problème...
Merci encore @ vous deux eriiic et X Cellus pour vos interventions.
ce sujet étant déjà résolu, il s'éteindra de lui-même, je retourne sur ma planche à dessin !
@ bientôt
LouReeD
Bonjour,
voici le code avec les caractères "spéciaux" modifiés, c'est plus lisible
// Rajouter manuellement ces unités.
Uses Windows, SysUtils, Graphics ;
// Calcule le nombre de couleurs d'une image BMP.
// Paramètres : Nom du fichier BMP sur le disque dur.
procedure TTestForm.LakCountColors ( Const FileName: String ) ;
// Impératif : l'évaluation booléenne complète DOIT être désactivée.
{$B-}
Const
// Profondeur de couleur maximale pour l'arbre.
Depth = 24 ;
Type
// Structure de comptage des couleurs.
PColorCell = TColorCell ;
TColorCell = Record
Child : Array[0..1] Of PColorCell ;
End ;
// Tableaux d'accès aux scanlines en mode 32 bits.
PCardinalArray = TCardinalArray ;
TCardinalArray = Array[0..8191] Of Cardinal ;
// Vérifie l'existence d'une cellule, l'alloue si nécessaire.
Function CheckCell ( Cell : PColorCell ; Const Child : Integer ; Var Created : Boolean ) : PColorCell ;
Begin
Created:=(Cell.Child[Child]=Nil);
If (Created) Then
Begin
New(Result);
FillChar(Result,SizeOf(Result),0);
Cell.Child[Child]:=Result;
End;
Result:=Cell.Child[Child];
End;
// Crée un arbre vide.
Function CreateTree : PColorCell ;
Begin
New(Result);
FillChar(Result,SizeOf(Result),0);
End;
// Détruit l'arbre
Procedure DestructTree ( Var Root : PColorCell ) ;
Begin
If Not Assigned(Root) Then
Exit ;
DestructTree(Root.Child[0]);
DestructTree(Root.Child[1]);
Dispose(Root);
End;
// Cherche une couleur dans l'arbre, ajoute le noeud si nécessaire.
Procedure SearchAndAdd ( Root : PColorCell ; Color : Cardinal ; Var RealSize : Cardinal ) ;
Var
Curr : PColorCell ;
I : Integer ;
Created : Boolean ;
Begin
Curr:=Root ;
// On calcule sur Depth bits.
For I:=1 To Depth Do
Begin
// Détermination du bit, parcours de l'arbre en fonction du bit.
Curr:=CheckCell(Curr,(Color And 1),Created);;
// Décalage de la couleur.
Color:=Color Shr 1 ;
End;
// Au dernier bit, on vérifie si la cellule a été créée ou pas.
// Si oui, c'est une nouvelle couleur.
If Created Then
Inc(RealSize);
End;
Var
Bmp : TBitmap ;
Root : PColorCell ;
ClrCount : Cardinal ;
X, Y, R : Cardinal ;
H, W, C : Cardinal ;
P : PCardinalArray ;
Begin
// Chargement de l'image.
Bmp:=TBitmap.Create;
Bmp.LoadFromFile(FileName);
// L'astuce est ici : on convertit en 32bpp pour booster le parcours des scanlines.
Bmp.PixelFormat:=pf32bit;
// Initialisation
ClrCount:=0;
Root:=CreateTree;
Progress.Position:=Progress.Min;
H:=Bmp.Height-1;
W:=Bmp.Width;
Progress.Max:=H;
// Parcours ligne à ligne.
For Y:=0 To H Do
Begin
Application.ProcessMessages;
P:=Bmp.ScanLine[Y];
// Parcours pixel par pixel
X:=0;
While (X<W) Do
Begin
C:=P[X];
// On cherche les pixels identique contigüs : pas la peine de répéter pour rien une recherche.
R:=X+1;
// ATTENTION : Ce code requiert d'avoir désactivé l'évaluation booléenne complète.
// Sinon, lorsque R=W, il y a Access Violation sur P[R].
While ((R<W) And (P[R]=C)) Do
Inc(R);
SearchAndAdd(Root,C,ClrCount);
X:=R;
End;
Progress.StepIt;
End;
DestructTree(Root);
ColorCount.Text:=IntToStr(ClrCount);
Bmp.Free;
Progress.Position:=Progress.Min;
end;@ bientôt
LouReeD
Bonjour,
Avec un tableau à trois index de RGB et le travaille sur l'image en mémoire avec GetPixel, je suis aux alentour des 5 secondes.
Avec ce même tableau, mais en prenant les couleurs dans un tableau 2D sous VBA qui lui est rempli par une boucle avec GetPixel je suis également aux alentours des 5 secondes. Si je ne prend pas en compte ce chargement de couleur dans le tableau 2D, le contrôle des couleurs uniques est de 0,5 secondes.
C'est vraiment le GetPixel qui est chronophage.
Sinon avec l'arbre binaire je suis à environ 50 secondes, et si je transforme l'arbre pour descendre à 12 niveaux, donc il n'y a pas de fils par nœuds mais 4 (00, 01, 11, 10) je descend à 30 secondes...
Par contre depuis la "correction" de la conversion du long en binaire, je tombe sur le même nombre de couleur unique dans tous les cas !
la conclusion : je reste sur mon tableau Boolean à 3 Index RGB. reste à trouver une instruction qui pourrait remplacer GetPixel...
@ bientôt
LouReeD