XL 2021 VBA - Pourquoi les imageMso ne se conservent pas dans le tableau ?

[Dudu2]

Bonjour,

Je suis parti de la liste des noms des imageMso créée par @patricktoulon dans sa ressource CreatorRibbonX ImageMso evolution.
Et j'ai essayé d'avoir une liste des images correspondantes.

1 - Le code pour extraire les images est très long (pour 8000+ images). Comment l'améliorer ?
2 - Une fois les images obtenues, une fermeture du classeur, puis une réouverture -> les images ont disparu ! Comment les conserver ?

Pour les essais, inutile d'aller au-delà de 3% sinon c'est trop long.
Merci par avance pour toute info.

 

[patricktoulon]

Bonjour @Dudu2
re ben tu sauve le classeur à la fermeture tout simplement
après je ne vois pas trop l'intérêt de faire un truc de ce genre
ton fichier va peser un certain poids (+ de 8000 images)
j'ai arrêté a 565 il fait déjà 217 kilos

si c'est pour avoir un visuel immédiat j'ai un fichier avec gallery si tu veux

 

[patricktoulon]

sans passer par un fichier temp mais directe avec un label a le screen updating false je vais un peu plus vite

Option Explicit

Sub ListeImageMso()
    Dim Tbl As ListObject
    Dim IPictureDisp As IPictureDisp
    Dim Shape As Shape
    Dim tempPath As String
    Dim RC As Integer
    Dim ErrNumber As Long
    Dim i As Long
   Application.ScreenUpdating = False
    'Tableau des imageMso
    Set Tbl = ThisWorkbook.Worksheets(1).ListObjects(1)
    
    For Each Shape In ActiveSheet.Shapes
        If Not Shape.Name = "Bouton" Then Shape.Delete
    Next Shape
    
    With Tbl
        For i = 1 To .ListRows.Count
            'Barre de progression
            RC = BarreProgression.Display("Touche <Entrée> pour interrompre", .ListRows.Count, i)
            
            If RC < 0 Then
                RC = MsgBox("Interruption demandée !" & vbCrLf & "Continuer ?", vbYesNo + vbQuestion)
                If RC = vbYes Then
                    Call BarreProgression.Continue
                End If
                
                If RC = vbNo Then
                    BarreProgression.Cancel
                    Exit Sub
                End If
            End If
            
            'Row Height
            ActiveSheet.Rows(.ListRows(i).Range.Row).RowHeight = 36
            
            ' Affiche l’icône
            On Error Resume Next
            Set IPictureDisp = CommandBars.GetImageMso(.ListColumns(1).DataBodyRange(i).Value, 32, 32)
            ErrNumber = Err.Number
            On Error GoTo 0
            
            If ErrNumber = 0 Then
                'tempPath = Environ("TEMP") & "\temp_logo.bmp"
               ' If Not Len(Dir(tempPath)) = 0 Then Kill tempPath
                'SavePicture IPictureDisp, tempPath
                
                Dim lbl As OLEObject
                Set lbl = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Label.1", _
                                                                 Left:=Tbl.DataBodyRange(i, 2).Left + 2, _
                                                                 Top:=Tbl.DataBodyRange(i, 2).Top + 2, _
                                                                 Width:=32, Height:=32)
                
                With lbl
                    .Name = "lblImg_" & i
                     .Object.Picture = CommandBars.GetImageMso(Tbl.ListColumns(1).DataBodyRange(i).Value, 32, 32)
                    .Object.PicturePosition = 12
                   .Object.Caption = ""
               End With
                
                'With ActiveSheet.Pictures.Insert(tempPath)
                    '.Left = Tbl.DataBodyRange(i, 2).Left + 2
                    '.Top = Tbl.DataBodyRange(i, 2).Top + 2
                    '.Width = 32
                    '.Height = 32
                'End With
            End If
            
            DoEvents
        Next i
    End With
End Sub

 

[Dudu2]

Merci @patricktoulon pour le code.
Je ne sais pas bien manipuler ces IPictureDisp et c'était surtout à titre d'exercice.
C'est vrai qu'en captant toutes ces images on finit avec un énorme classeur pas viable.

Pour la liste les imageMso j'ai ça -> https://codekabinett.com/download/Microsoft-Office-2016_365-imageMso-Gallery.pdf

Si tu as autre chose, je veux bien voir ce que c'est.

 

[patricktoulon]

c'est vrai que l'on s'y perd un peu vite avec ces objects
d'autant plus que même vba s'y perd en lecture d'ailleurs il ne renvoie pas toujours le bon object
et même dans certaines conditions ces object doivent être déclarés en variant sinon la lecture plante

Objet	Type	Utilisation principale	Exposé à VBA
[B][SIZE=5]IPicture[/SIZE][/B]	Interface COM	Accès bas niveau aux images	non
[B][SIZE=5]IPictureDisp[/SIZE][/B]	Interface COM	Version Automation-friendly de IPicture	Oui
[B][SIZE=5]StdPicture[/SIZE][/B]	Objet COM	Implémentation concrète des deux	Oui

pour ma gallery voici mon fichier il date de de 2023 il est peut être pas complet comme le creatrRibbonX mais comme tu peux le voir il n'y a pas d'attente tout est interne dans le ruban je pourrais même m'amuser a créer un moteur de recherche intra Ribbon ( les gallery sont scrollables quand il y en a beaucoup)

 

[Valtrase]

Bonjour à tous,
Je ne sais pas quelle utilisation tu veux en faire, mais à l'époque j'ai trouvé cela. Les images sont dans ImageMso0 et ImageMso1 du BackStage.

 

[Dudu2]

Bonjour @Valtrase,
Oui j'avais vu ce Word et me suis étonné de trouver les images dans ce "BackStage" dont j'ignorais l'existence.
C'est bizarre comme méthode.

 

[Dudu2]

J'ai ces 2 erreurs à l'ouverture:

Mais ça n'a pas d'importance.
Ce qu'il faut c'est une visibilité globale pour voir ce qui existe.

 

[patricktoulon]

tu veux que je te le refasse avec tout ceux du creator ?
et le backstage je t'en ai un peu parlé la derniere fois
je peux le faire sur le ruban ou le backstage comme tu veux dans excel

 

[Dudu2]

Je veux pas t'imposer du boulot.
Si tu penses que ça peut être utile à tous les utilisateurs, fais comme tu le sens.

 

[patricktoulon]

ok laisse moi 5/6 minutes

 

[patricktoulon]

et voila crée avec creatorRibonX 2025 v 7.0
tu a les 26 lettres + les "_xxxx"
et tu a un moteur de recherche tape une partie du genre "print" ou encore "save" ou tout autres expression et fini par enter
ensuite clique sur la loupe et tu aura tout les icones contenant cette expression

nb:
pour info la version 7.0 n'est pas encore publiée
elle permet de reprendre à volonté un fichier déjà customisé a partir de son projet sans devoir tout refaire

je vais faire la vidéo demain de démonstration
et/ ou cours démo sur teams pour ceux qui ont déjà participé

@Dudu2 c'est un poil plus long que celle que je t'ai donné ou les gallery étaient codées en dur dans le xml
plus il y a d’occurrence plus c'est long mais moins que ta mecanique sur feuille

ici chaque gallery est vide au départ elle se remplissent au dropclick en filtrant les intrus

pour que tu soit tranquille j'ai mis une gestion d'erreur sur les icons qui seront invalides dans ta version d'excel il sont signalé dans la gallery comme ceci

Patrick

 

[Dudu2]

Impressionnant ! 😱 Merci pour le fichier.

pour info la version 7.0 n'est pas encore publiée
elle permet de reprendre à volonté un fichier déjà customisé a partir de son projet sans devoir tout refaire

Le grand luxe ! 👍