Mosaïque maker

Bonsoir @ tous !

Et bien voici le dernier venu ! Il n'a prévenu personne !

Je travaille dessus depuis plusieurs mois, et voilà, il est terminé !

C'est une application qui comme l'a proposé Sébastien sur le site, vous permet de transformer une image en "mosaïque" sur une feuille Excel.

Elle vous propose dans un USF de choisir votre image, puis elle s'occupe du reste, un peu de patience vous est demandée, et le résultat "ne se fait pas attendre"... Enfin cela dépend de l'image et de votre machine pour faire tourner l'application !

Je la met ce soir en "validation" auprès de Sébastien.

@ bientôt

LouReeD

Bonjour,

quelle joie pour moi de voir ce matin que l'application a été validée dans "la nuit" !

J'espère qu'elle vous plaira !

Merci Sébastien pour, une nouvelle fois, votre promptitude !

@ bientôt

LouReeD

Bonjour,

Suite à des tests, et une recherche sur internet je dois vous annoncé au moins une limite de plus :

Les feuilles Excel sont limitées à 64 000 formats de remplissage...

Après des tests sur ma machine j'ai une erreur à 65 428 couleurs différentes ce qui est en concordance avec ce qu'annonce Microsoft.

Donc vos mosaïques seront "entières" tant que l'image ne comporte pas plus de 64 000 teintes différentes, ce qui peut très vite arriver avec les compression JPG qui crées énormément de "dégradé".

Voilà, il fallait le préciser, non ?

@ bientôt

LouReeD

Bonjour,

Juste pour dire que je vais me servir de Mosaïque Maker pour mon application en cours "Major Motion", un régal pour la création des décors... Beaucoup plus simple et rapide que de le faire à la main... Soit, il y a un "gros" travail au départ mais ensuite c'est plus simple...

Merci LouReeD pour cette application !

@ bientôt

LouReeD

Bonsoir,

après plus d'un an juste un petit message pour annoncer la version 2 :
des petits ajouts fort bien utiles...

@ bientôt

LouReeD

Bonjour LouReeD,

Des petits ajouts bien utiles en effet auquel je t'en suggère un autre le jour où tu souhaiteras te replonger dans cette application:

Offrir une fonction réciproque retraduisant les interior.color de la feuille Excel en image jpg, gif ou bmp comme ton app les assumes.

Cela permettrait d'effectuer des traitements par d'autres logiciels ( …) et de restituer une image.

Que penses-tu de cette idée ? Dur à programmer ?

@ +

Bonsoir,

faut voir... Ceci dit c'est ce que fait déjà "l'appareil photo" d'Excel : on sélectionne une plage puis clic photo, et voilà une belle image...

@ bientôt

LouReeD

Re-bonjour LouReeD,

Je ne connaissais pas l'appareil photo d'Excel, merci pour l'astuce. Il permet en effet d'obtenir une image de même résolution que l'original plus simplement qu'avec un Impr Ecran sur ta feuille zoomée à 25% (ça marchait aussi mais il restait à détourer l'image).

@ la prochaine

Mais de rien, si ça peut faire avancer les choses.

Après en VBA avec l'enregistreur ou autre il y aura un code pour enregistrer cette image.

@ bientôt

LouReeD

Bonjour LouReeD,

Si tu veux améliorer ton programme, tu trouveras un fichier Excel qui a été créer en novembre 2005 qui faisait déjà cela.

Le programme avait été créer par Thierry Pourtier, une personne qui était fort active sur le WEB.

Le programme s'appelait TAPISSERIEXLD.

Bonne journée

Bonsoir,

à mon niveau la seule amélioration serait de compter exactement le nombre de couleur différente et unique d'une image à la façon de "IrfanView" qui lors du clic droit sur une photo et "détails" de cette dernière il est capable de dire qu'elle est constituée de 124942 couleur différentes !

Hors Excel ne supporte pas plus de 65490 format/style de cellules différentes, donc j'ai mis en place une routine qui calcule les couleurs différentes de l'image choisie et pour un gain de temps je la stoppe à 16000 couleur avec un message indiquant à l'utilisateur que l'image de sortie pourrait être imparfaite.
Cette routine est longue... C'est donc bien ce point que je souhaite améliorer.

Sinon pour le résultat final, ma version est plus proche de la réalité car il n'y a pas de modification de résolution ni du nombre de couleur.

Image test qui contient d'après IrfanView 62158 couleurs différente :

doudou est en colere

image créée avec l'application tapisserie :

tapisserie

image crée avec Mosaïque :

mosaique

beaucoup moins pixelisée, les textes sont lisibles, et les couleurs sont restituées !

EDIT 25/11/2022 :

Image issue de la version 4 bientôt en téléchargement :

image

Ici c'est donc avec une réduction des couleurs en créant des curseurs RGB de 32 à la place de ceux des "couleurs vraies" qui sont de 256 !
Du coup 32 x 32 x 32 = 32768 couleur différentes ce qui à chaque fois est affichables sous Excel car ce dernier est limité à 65490 formats.

Merci à Stéphane1972 qui m'a proposé la fonction "d'arrondi" des couleurs afin de les regrouper en une seule lorsqu'elles ont des positions de curseur équivalentes.

FIN EDIT DU 25/11/2022

Donc oui je cherche à l'améliorer ( c'est fait ! ) mais juste au niveau de la routine de recherche du nombre de couleur différentes composant l'image afin d'être sûr que la création ne comportera pas de "trous", car si le quota de style de cellule est atteint, alors la cellule de la feuille reste blanche.

Mais ceci dit merci pour le lien, et je vais regarder comment l'auteur fait pour réduire la palette de couleur de l'image à 56 ! Si je comprends le système je pourrais peut être alors limiter (modifier) les couleurs afin que le nombre ne dépasse pas les 65490 !

@ bientôt

LouReeD

Bonsoir,

voilà, modification de la version à télécharger, on passe en version 3.0 !
Quelques modifications de code VBA, mais surtout amélioration de la routine de comptage des couleurs uniques des images.
C'est un peu long pour les images de plus de 100000 couleurs différentes, pour les autres cela va relativement vite.

Un message vous informes du nombre exacte de couleur unique, et si ces dernières dépasse le nombre de 65490 alors on vous prévient qu'il y aura des "trous" dans la mosaïque.

@ bientôt

LouReeD

Bonjour LouReeD,

Suggestion : pourquoi ne pas offrir la possibilité d’une réduction du nombre de couleurs ? (par un CommandButton ?) en avertissant que cela ralentira le calcul.

Une procédure du goût de celle qui suit me semblait faire le job, c'est souvent le cas mais testez un CouleurArrondie(255) et vous verrez qu'il y a malaise enfin vous avez compris l'idée.

Function CouleurArrondie&(ByVal CouleurO&, _
            Optional ByVal NbEtages As Byte = 32)

' si NbEtages = 128 -> 128^3 = 2 097 152 couleurs
' 64 -> 262144 couleurs
' 32 -> 32768
' 16 -> 4096
' 8 -> 512
' 4 -> 64
' 2 -> 8

Dim R As Byte, G As Byte, B As Byte
Dim C As Byte

On Error GoTo RetZero

C = Int(256 / NbEtages)

R = Int((CouleurO& Mod 256) / C) * C
G = Int((CouleurO& / 256 Mod 256) / C) * C
B = Int((CouleurO& / 65536 Mod 256) / C) * C

CouleurArrondie& = RGB(R, G, B)

RetZero:
End Function

En conservant la valeur du nombre d’étages par défaut de 32 soit 32768 couleurs la perte de qualité de l’image mosaïquée est faible et ça passe au niveau des restrictions Excel. Le classeur joint reprend ce code avec en plus une Feuille avec random sur l’intervalle 0 à capacité Long et comparaison des deux couleurs. Mais encore une fois cette routine peut être prise en défaut...

@ +

Stéphane

Bonsoir,

voilà qui relance le sujet ! Merci @ vous !

Je vais tester ce code afin de le comprendre et voir s'il me convient !

@ bientôt

LouReeD

Bon, j'ai regardé et je n'ai pas tout compris.

Toujours est-il que si l'on propose une réduction de couleur avec une "augmentation" du temps de traitement, alors autant que je reste sur le calcul du nombre de couleur unique.

Par contre lorsque je fais ma boucle de comptage des couleurs "grâce" au dico VBA :

    ' on compte le nombre de couleur de l'image avec l'image en mémoire
    ' ceci permet d'aller beaucoup plus vite
    For I = 0 To Max_X
        For J = 0 To Max_Y
            MonDico(GetPixel(ImgEcran_Hdc, J, I)) = ""
            DoEvents
        Next J
    Next I

il faudrait que je transforme à la volée la valeur "couleur" du pixel testé par une couleur existante approchante afin d'en réduire le nombre dans l'image.
Donc l'idée serait :
- pixel(1,1) = rouge145, => par l'arrondi 32 le rouge145 se trouve entre le rouge17 et le rouge217 => donc pixel(1,1)=couleur(rouge "moyen de la fourchette" rouge117)
- pixel(1,2) = rouge209=> par l'arrondi 32 le rouge209 se trouve entre le rouge17 et le rouge217 => donc pixel(1,2)=couleur(rouge "moyen de la fourchette" rouge117)

Si votre code arrondi les 16000000 de couleur en 32768 alors au final j'aurais une image de moins de 65490 couleurs et ce sans "rien dire" à l'utilisateur.
La "retouche" de ces couleur se faisant "en mémoire" autant cela peut aller vite et le reste du code transforme cette image mémoire en cellule colorée sous excel !

à lire comme cela ça me semble bien en effet, maintenant comment savoir que tel couleur fait partie de cette plage d'arrondi afin de la remplacer par la couleur moyenne de la plage ?

Les couleurs n'étant pas linéaires les plages ne marchent par lot contigüe : 0 à 511 noir, 512 à 1023 , gris foncé etc
Mais merci je vais "gratter" dans ce sens et je ne compterais plus les couleurs uniques je transformerais automatiquement toutes les couleurs !

@ bientôt

LouReeD

Voyez comme j'ai du mal à comprendre ce que l'on me montre sous le nez !
votre code remplace les valeurs RGB d'une couleur quelconque en valeur RGB avec 32 niveau de curseur au lieu de 256 !

Donc dans ma boucle de récupération de couleur il me suffit de remplir un tableau(X,Y) avec les couleur arrondies récupérées avec GetPixel !

    ' on diminue le nombre de couleur de l'image avec l'image en mémoire
    ' ceci permet d'aller beaucoup plus vite
    For I = 0 To Max_X
        For J = 0 To Max_Y
            TabCoulArrondies(I,J)= CouleurArrondie&(ByVal GetPixel(ImgEcran_Hdc, J, I))
            DoEvents
        Next J
    Next I

et votre code :

Function CouleurArrondie&(ByVal CouleurO&)
Dim R As Byte, G As Byte, B As Byte
Dim C As Byte
On Error GoTo RetZero
    C = Int(256 / 32)
    R = Int((CouleurO& Mod 256) / C) * C
    G = Int((CouleurO& / 256 Mod 256) / C) * C
    B = Int((CouleurO& / 65536 Mod 256) / C) * C
    CouleurArrondie& = RGB(R, G, B)
RetZero:
End Function

et voilà cela devrait fonctionner, je vais de ce pas essayer !

@ bientôt

LouReeD

Bonsoir,

et bien voici le résultat : effacé par LouReed

Le fichier ne restera pas longtemps afin de ne pas interférer avec la zone de téléchargement. Stéphane1972, merci de me prévenir lorsque vous l'aurez "vu".

Il me reste à modifier l'affichage de la progresse barre qui peut maintenant gérer les deux partie du code : indexation des couleurs et production de la Mosaic.

Merci encore à vous Stéphane1972 !

@ bientôt

LouReeD

Pour un test voici l'image de l'ours en colère vu plus haut :

image

@ bientôt

LouReeD

Bonjour,

Après réflexion, je vais utiliser un "curseur" de 40 en place de celui de 32 ! En effet : 40x40x40 = 64000 ! Du coup je serai presque au même niveau que la limite acceptée d'Excel !

@ bientôt

LouReeD

Bonjour LouReeD,

Vous êtes matinal !

(Aujourd'hui à 06:23)

. Voici la version corrigée et qui cette fois si semble bien marcher de CouleurArrondies& (je vous avais signalé dans mon Post précédent que cette fonction donnait parfois des résultats erronés). A priori vous devriez pouvoir utiliser un nombre d'étages de 40 (qui n'est pas une quantité puissance de deux) sans problèmes.

Je suis enchanté que vous réutilisiez cette fonction pour votre application.

Voici donc le nouveau code :

Function CouleurArrondie&(ByVal CouleurO&, _
                          Optional ByVal NbEtages As Byte = 32)
    ' si NbEtages = 128 -> 128^3 = 2 097 152 couleurs
    ' 64 -> 262144 couleurs; 32 -> 32768; 16 -> 4096; 8 -> 512...
    ' ... 4 -> 64; 2 -> 8 (il semble possible d'utiliser d'autres...
    ' ... NbEtages qui ne soient pas des n ^ 2)
    Dim C As Byte
    On Error GoTo RetZero
    C = Int(256 / NbEtages)
    CouleurArrondie& = RGB(Int((CouleurO& Mod 256) / C) * C, _
                           Int(Int((CouleurO& Mod 65536) / 256) / C) * C, _
                           Int(Int((CouleurO& Mod 16777216) / 65536) / C) * C)
RetZero:
End Function

@+

Rechercher des sujets similaires à "mosaique maker"