Microsoft 365 Mozaïque photos

[Claudy]

Bonjour,
Comment insèrer sous forme de mozaique, de façon aléatoire dans une feuille, des photos(30) se trouvant dans un dossier?
Il peut y avoir des doublons dans la mozaïque.
VBA accepté.

Merci d'avance,

Claudy

 

[kiki29]

Salut,si curieux,à télécharger puis consulter/adapter à ton contexte : Liste Contributions PDF
y voir les posts 210/211

 

[sylvanu]

Bonjour Claudy, Kiki,
Un essai en PJ inspiré de ChatGPT.

 

[sousou]

Bonjour
Ma gestion d'images sur ce site propose un vignettage, pour infos

 

[patricktoulon]

WOAWH !!!
punaise si chatGpt est capable de sortir un truc aussi brouillon on peut s'inquiéter

Je vous propose de travailler proprement sur la feuille

1. On utilisera des plages paramétrables
2. Ma fonction de placement avec centrage d'image sur range

Et on fait une gallery propre et net

'patricktoulon
Sub clearGallery()
    Dim shap As Shape
    'clear la page
    For Each shap In ActiveSheet.Shapes
        If shap.Name <> "BoutonGo" Then shap.Delete
    Next
    Cells.Clear
End Sub
Sub CreatePictureGallery()
    
    Dim p As Range, LargeurCase&, Hauteurcase&, NbCol&, L&, C&, fichiers
    '---------------------------------------
    clearGallery
    '-----------------------------------------
    LargeurCase = 2 'largeur de la case en colonnes
    Hauteurcase = 7 'hauteur de la case en lignes
    NbCol = 4 'nombre de case par ligne
    
    C = 1 'colonne de depart
    L = 2 'ligne deparat
    'dialog folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "CHOISISSEZ LE DOSSIER D IMAGES"
        If .Show <> -1 Then Exit Sub
        dossier = .SelectedItems(1) & "\"
    End With
    
    'dir fichier
    fichiers = Dir(dossier & "\*.*")
    If fichiers <> "" Then
        Do While fichiers <> ""
            Select Case Split(LCase(fichiers), ".")(1)
                Case "jpg", "jpeg", "png", "gif", "bmp"
                    Set p = Cells(L, C).Resize(Hauteurcase, LargeurCase)
                    p.BorderAround 1, 2, 3 'encadrement en rouge(facultatif)
                    DoEvents
                    'insertion de limage
                    Set img = ActiveSheet.Pictures.Insert(dossier & fichiers)
                    PlaceTheShapeInCenterRange p, img, 90 '90%
                    C = C + LargeurCase 'passe a la case suivante
                    If C = (1 + (LargeurCase * NbCol)) Then C = 1: L = L + Hauteurcase 'on change de ligne au bout de 4 case alignées
            End Select
            fichiers = Dir
        Loop
    End If
End Sub

Sub PlaceTheShapeInCenterRange(rng As Range, shap As Variant, Optional marge As Long = 100) 'la marge exprime un pourcentage de 1 à x%
    'fonction de placement et centrage d'image dans un range
    'auteur:patricktoulon
    'Archive 2020;Version :2020
    Dim Ratio#, Shapo As Shape
    Ratio = Application.Min(((rng.Width) * (marge / 100)) / shap.Width, ((rng.Height) * (marge / 100)) / shap.Height)
    Set Shapo = ActiveSheet.Shapes(shap.Name)
    With Shapo
        .LockAspectRatio = msoTrue
        .Width = (.Width * Ratio)
        .Top = rng.Top + ((rng.Height - .Height) / 2)
        .Left = rng.Left + ((rng.Width - .Width) / 2)
    End With
End Sub

Voilà toutes centrées au milieu de leurs cases

elle peuvent être de taille et ration différentes les une entre les autres elle seront reimentionnées et centrée en gardant leur ration

Patrick j'ai pété

 

[Claudy]

Bonsoir à tous,
merci pour vos réponses,
Malheureusement , je ne saurai tester que lundi prochain, je vous tiendrai au courant,

Bonne soirée,

Claudy

 

[Claudy]

Bonjour Patrick,
Merci beaucoup, j'avance dans mon projet...
Mais comment adapter ton code pour que les images soient placées sans blancs entre elles, quite à faire des doublons pour remplir une page?

Merci

Claudy

WOAWH !!!
punaise si chatGpt est capable de sortir un truc aussi brouillon on peut s'inquiéter

Je vous propose de travailler proprement sur la feuille

1. On utilisera des plages paramétrables
2. Ma fonction de placement avec centrage d'image sur range

Et on fait une gallery propre et net

'patricktoulon
Sub clearGallery()
    Dim shap As Shape
    'clear la page
    For Each shap In ActiveSheet.Shapes
        If shap.Name <> "BoutonGo" Then shap.Delete
    Next
    Cells.Clear
End Sub
Sub CreatePictureGallery()
   
    Dim p As Range, LargeurCase&, Hauteurcase&, NbCol&, L&, C&, fichiers
    '---------------------------------------
    clearGallery
    '-----------------------------------------
    LargeurCase = 2 'largeur de la case en colonnes
    Hauteurcase = 7 'hauteur de la case en lignes
    NbCol = 4 'nombre de case par ligne
   
    C = 1 'colonne de depart
    L = 2 'ligne deparat
    'dialog folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "CHOISISSEZ LE DOSSIER D IMAGES"
        If .Show <> -1 Then Exit Sub
        dossier = .SelectedItems(1) & "\"
    End With
   
    'dir fichier
    fichiers = Dir(dossier & "\*.*")
    If fichiers <> "" Then
        Do While fichiers <> ""
            Select Case Split(LCase(fichiers), ".")(1)
                Case "jpg", "jpeg", "png", "gif", "bmp"
                    Set p = Cells(L, C).Resize(Hauteurcase, LargeurCase)
                    p.BorderAround 1, 2, 3 'encadrement en rouge(facultatif)
                    DoEvents
                    'insertion de limage
                    Set img = ActiveSheet.Pictures.Insert(dossier & fichiers)
                    PlaceTheShapeInCenterRange p, img, 90 '90%
                    C = C + LargeurCase 'passe a la case suivante
                    If C = (1 + (LargeurCase * NbCol)) Then C = 1: L = L + Hauteurcase 'on change de ligne au bout de 4 case alignées
            End Select
            fichiers = Dir
        Loop
    End If
End Sub

Sub PlaceTheShapeInCenterRange(rng As Range, shap As Variant, Optional marge As Long = 100) 'la marge exprime un pourcentage de 1 à x%
    'fonction de placement et centrage d'image dans un range
    'auteur:patricktoulon
    'Archive 2020;Version :2020
    Dim Ratio#, Shapo As Shape
    Ratio = Application.Min(((rng.Width) * (marge / 100)) / shap.Width, ((rng.Height) * (marge / 100)) / shap.Height)
    Set Shapo = ActiveSheet.Shapes(shap.Name)
    With Shapo
        .LockAspectRatio = msoTrue
        .Width = (.Width * Ratio)
        .Top = rng.Top + ((rng.Height - .Height) / 2)
        .Left = rng.Left + ((rng.Width - .Width) / 2)
    End With
End Sub

Voilà toutes centrées au milieu de leurs cases
Regarde la pièce jointe 1225261

 

[patricktoulon]

Bonjour @Claudy

Mais comment adapter ton code pour que les images soient placées sans blancs entre elles, quite à faire des doublons pour remplir une page?

Je vais te demander de réfléchir un peu plus
Pose-toi la question
Comment coller des images côte à côte et dessus dessous ou celles-ci n'auraient potentiellement pas le même ratio.

Je pense que la réponse va être flagrante si tu te donnes la peine d'y réfléchir une seconde.

C’est pour cela que dans ce que je t'ai proposé,une table est virtuellement créée afin d'afficher proprement les images en gardant leur ratio intègre.

Ce que tu décris est un patchwork et tenter un algo pour le créer serait une perte de temps (pas impossible mais il y aurait tellement de situations possibles que ça n'en finirait jamais).

si le patchwork est vraiment un impératif , tu perdrais moins de temps à le faire à la main.
Surtout pour 30 images

 

[Claudy]

Bonjour @Claudy

Je vais te demander de réfléchir un peu plus
Pose-toi la question
Comment coller des images côte à côte et dessus dessous ou celles-ci n'auraient potentiellement pas le même ratio.

Je pense que la réponse va être flagrante si tu te donnes la peine d'y réfléchir une seconde.

C’est pour cela que dans ce que je t'ai proposé,une table est virtuellement créée afin d'afficher proprement les images en gardant leur ratio intègre.

Ce que tu décris est un patchwork et tenter un algo pour le créer serait une perte de temps (pas impossible mais il y aurait tellement de situations possibles que ça n'en finirait jamais).

si le patchwork est vraiment un impératif , tu perdrais moins de temps à le faire à la main.
Surtout pour 30 images

Re bonjour Patrick,
ok avec toi,
je pense que je vais le faire à la ain.

Bonne journée,

Claudy

 

[patricktoulon]

a moins de travailler sur un seul axe et voir si possible combler avec des shapes texturées

 

[danielco]

Bonjour à tous,

Avec Excel 365, une solution sans macro. Les images changent avec la touche F9.

Daniel

 

[Valtrase]

Bonjour à tous,
Hum je viens de tomber sur ce sujet.
Si on pose les bonnes questions on peut avoir des réponses acceptables.
Voici un petit exemple généré par IA. (Et ajuster par bibi).
Vous pouvez définir quelques réglages au niveau de la feuille des paramètres, et notamment l'espacement entre chaque forme, leur dimensions ,et si l'on doit respecter le ratio.

Faites un test et dite-nous si cela correspond à votre recherche.
Bonne programmation.

 

[patricktoulon]

Pour afficher ce contenu, nous aurons besoin de votre consentement pour définir des cookies tiers.
Pour plus d'informations, consultez notre page sur les cookies.

Accepter les cookies de tiers

 

[Valtrase]

Salut Patrick,
Dans le fichier exemple la hauteur et la largeur des formes sont définit sur la feuille paramètres (soit 20 X 20) change la hauteur et largeur indique aussi si l'on dois garder le ratio et refait le test.
PS si j'ai bien compris il veux mettre des images qui sont choisies aléatoirement dans un répertoire et les afficher aléatoirement sur la feuille

 

[patricktoulon]

Bonsoir @valtraze
j'avoue que je ne sais pas quoi changer pour les rapprocher
je ne suis pas sur que ca corresponde à la demande en fait
Le côté aléatoire des images n' est que d'elles-mêmes en fait pas de leurs positions.
ce que cherche claudy est un patchwork