XL 2016 Centrer Images

halecs93 · 16 Août 2023

Bonjour,

J'ai un fichier excel qui me permet de générer des grilles d'accords pour la guitare. Il se base sur des images stockées en feuil2.

Mon code VBA me permet d'aller chercher des accords sur cette feuille pour les coller en feuil1.

Souci, je ne m'en sors pas pour centrer horizontalement les images trouvées et collées.

Sui quelqu'un a une solution... je suis preneur.

Merci tout le monde

RyuAutodidacte · 16 Août 2023

Bonjour,
J'ai aussi modifier la sub pour effacer les images, sinon cela efface tes boutons qui sert aux macros
Sinon la macro positionne les images centrer dans la cellules en une seule fois selon la Range défini :

VB:

Sub EffacerImages()
    Dim ws As Worksheet
    Dim shp As Shape
   
    ' Spécifiez la feuille sur laquelle vous souhaitez supprimer les images
    Set ws = ThisWorkbook.Sheets("Feuil1")
   
    ' Parcourez toutes les formes (images) sur la feuille et supprimez-les
    For Each shp In ws.Shapes
        If Not Application.Intersect(ws.Range(shp.TopLeftCell.Address), ws.Range("A1:H14")) Is Nothing Then
            shp.Delete
        End If
    Next shp
End Sub

Sub PosImgInCell()
    Dim obj As Shape, C As Range
    For Each obj In ActiveSheet.Shapes
         myObjRg = obj.TopLeftCell.Address
        If obj.Type = msoPicture Then
            If Not Application.Intersect(Range(myObjRg), ActiveSheet.Range("A1:H14")) Is Nothing Then
                obj.ScaleWidth 1.5, msoTrue
                obj.ScaleHeight 1.5, msoTrue
                Set C = obj.TopLeftCell
                obj.Left = C.Left + (C.Width / 2) - (obj.Width / 2)
                obj.Top = C.Top + (C.Height / 2) - (obj.Height / 2)
                End If
        End If
    Next obj
End Sub

halecs93 · 16 Août 2023

RyuAutodidacte à dit:

Bonjour,
J'ai aussi modifier la sub pour effacer les images, sinon cela efface tes boutons qui sert aux macros
Sinon la macro positionne les images centrer dans la cellules en une seule fois selon la Range défini :

VB:

Sub EffacerImages()
    Dim ws As Worksheet
    Dim shp As Shape
  
    ' Spécifiez la feuille sur laquelle vous souhaitez supprimer les images
    Set ws = ThisWorkbook.Sheets("Feuil1")
  
    ' Parcourez toutes les formes (images) sur la feuille et supprimez-les
    For Each shp In ws.Shapes
        If Not Application.Intersect(ws.Range(shp.TopLeftCell.Address), ws.Range("A1:H14")) Is Nothing Then
            shp.Delete
        End If
    Next shp
End Sub

Sub PosImgInCell()
    Dim obj As Shape, C As Range
    For Each obj In ActiveSheet.Shapes
         myObjRg = obj.TopLeftCell.Address
        If obj.Type = msoPicture Then
            If Not Application.Intersect(Range(myObjRg), ActiveSheet.Range("A1:H14")) Is Nothing Then
                obj.ScaleWidth 1.5, msoTrue
                obj.ScaleHeight 1.5, msoTrue
                Set C = obj.TopLeftCell
                obj.Left = C.Left + (C.Width / 2) - (obj.Width / 2)
                obj.Top = C.Top + (C.Height / 2) - (obj.Height / 2)
                End If
        End If
    Next obj
End Sub

halecs93 · 16 Août 2023

Merci pour cette réponse.

Mais en fait, je cherchais un moyen à ce que les shapes se positionnent dès la macro 'insérerimagesmodifié"...

Je n'arrive pas à l'inclure dans cette macro.

Dranreb · 16 Août 2023

Bonjour.
Vous pouvez invoquer cette macro à la fin :

VB:

Sub CentrerShapes()
   Dim Shp As Shape
   For Each Shp In ActiveSheet.Shapes
      With ActiveSheet.Range(Shp.TopLeftCell, Shp.BottomRightCell)
         Shp.Left = .Left + (.Width - Shp.Width) / 2
         Shp.Top = .Top + (.Height - Shp.Height) / 2
         End With
      Next Shp
   End Sub

Il n'empêche que vous auriez intérêt à effacer tous les Shapes au début de votre Sub InsérerImagesModifié pour ne pas vous retrouver avec des tonnes l'un sur l'autre …

Dranreb · 16 Août 2023

Vous pouvez peut être le faire comme ça :

VB:

Sub InsérerImagesModifié()
    Dim ws As Worksheet
    Dim wsImages As Worksheet
    Dim i As Integer, j As Integer
    
    ' Définir la feuille de calcul à utiliser
    Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez "Feuil1" par le nom de votre feuille
    Set wsImages = ThisWorkbook.Sheets("Feuil2") ' Remplacez "Feuil2" par le nom de la feuille contenant les images

'Supprime les anciens Shape
    For Each Img In ws.Shapes
      If Img.Type = msoPicture Then Img.Delete
      Next Img
    
    ' Parcours des lignes avec les noms de notes de musique
    For i = 5 To 13 Step 2 ' Lignes B5, B7, B9, B11, B13
        For j = 2 To 8 ' Colonnes B à H
            Dim nomImage As String
            nomImage = ws.Cells(i, j).Value
            
            ' Chercher l'image correspondante dans la feuille "Feuil2"
            Dim imgShape As Shape
            On Error Resume Next
            Set imgShape = wsImages.Shapes(nomImage)
            If Err Then Set imgShape = Nothing
            On Error GoTo 0
            
            ' Si l'image est trouvée, copier et coller dans la feuille "Feuil1"
            If Not imgShape Is Nothing Then
                CopieShape imgShape, ws.Cells(i + 1, j)
            End If
        Next j
    Next i
   End Sub
Sub CopieShape(ByVal Shp As Shape, ByVal Cel As Range)
   Dim Wsh As Worksheet
   Set Wsh = Cel.Worksheet
   Shp.Copy
   Wsh.Paste
   Set Shp = Wsh.Shapes(Wsh.Shapes.Count)
   Shp.Left = Cel.Left + (Cel.Width - Shp.Width) / 2
   Shp.Top = Cel.Top + (Cel.Height - Shp.Height) / 2
   End Sub

halecs93 · 16 Août 2023

Dranreb à dit:

Vous pouvez peut être le faire comme ça :

VB:

Sub InsérerImagesModifié()
    Dim ws As Worksheet
    Dim wsImages As Worksheet
    Dim i As Integer, j As Integer
   
    ' Définir la feuille de calcul à utiliser
    Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez "Feuil1" par le nom de votre feuille
    Set wsImages = ThisWorkbook.Sheets("Feuil2") ' Remplacez "Feuil2" par le nom de la feuille contenant les images

'Supprime les anciens Shape
    For Each Img In ws.Shapes
      If Img.Type = msoPicture Then Img.Delete
      Next Img
   
    ' Parcours des lignes avec les noms de notes de musique
    For i = 5 To 13 Step 2 ' Lignes B5, B7, B9, B11, B13
        For j = 2 To 8 ' Colonnes B à H
            Dim nomImage As String
            nomImage = ws.Cells(i, j).Value
           
            ' Chercher l'image correspondante dans la feuille "Feuil2"
            Dim imgShape As Shape
            On Error Resume Next
            Set imgShape = wsImages.Shapes(nomImage)
            If Err Then Set imgShape = Nothing
            On Error GoTo 0
           
            ' Si l'image est trouvée, copier et coller dans la feuille "Feuil1"
            If Not imgShape Is Nothing Then
                CopieShape imgShape, ws.Cells(i + 1, j)
            End If
        Next j
    Next i
   End Sub
Sub CopieShape(ByVal Shp As Shape, ByVal Cel As Range)
   Dim Wsh As Worksheet
   Set Wsh = Cel.Worksheet
   Shp.Copy
   Wsh.Paste
   Set Shp = Wsh.Shapes(Wsh.Shapes.Count)
   Shp.Left = Cel.Left + (Cel.Width - Shp.Width) / 2
   Shp.Top = Cel.Top + (Cel.Height - Shp.Height) / 2
   End Sub

Du coup, les shapes se centrent jusqu'à rencontrer une erreur 400... bug dans mon code ?

fanch55 · 16 Août 2023

Bonjour à tous,
Codes proposés :

VB:

Sub EffacerImages()
    Dim ws As Worksheet
    Dim shp As Shape
    
    ' Spécifiez la feuille sur laquelle vous souhaitez supprimer les images
    Set ws = ThisWorkbook.Sheets("Feuil1")
    
    ' Parcourez toutes les formes (images) sur la feuille et supprimez-les
    For Each shp In ws.Shapes
        If shp.Type = msoPicture Then shp.Delete
    Next shp
End Sub

Sub InsérerImagesModifié()
    Dim ws As Worksheet
    Dim wsImages As Worksheet
    Dim i As Integer, j As Integer
    EffacerImages
    
    ' Définir la feuille de calcul à utiliser
    Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez "Feuil1" par le nom de votre feuille
    Set wsImages = ThisWorkbook.Sheets("Feuil2") ' Remplacez "Feuil2" par le nom de la feuille contenant les images
    
    ' Parcours des lignes avec les noms de notes de musique
    For i = 5 To 13 Step 2 ' Lignes B5, B7, B9, B11, B13
        For j = 2 To 8 ' Colonnes B à H
            Dim nomImage As String
            nomImage = ws.Cells(i, j).Value
            
            ' Chercher l'image correspondante dans la feuille "Feuil2"
            Dim imgShape As Shape
            On Error Resume Next
            Set imgShape = wsImages.Shapes(nomImage)
            On Error GoTo 0
            
            ' Si l'image est trouvée, copier et coller dans la feuille "Feuil1"
            If Not imgShape Is Nothing Then
                imgShape.Copy
                ws.Paste Destination:=ws.Cells(i + 1, j)
                With ws.Shapes(ws.Shapes.Count)
                    .Left = ws.Cells(i + 1, j).Left + (ws.Cells(i + 1, j).Width - .Width) / 2
                    .Top = ws.Cells(i + 1, j).Top + (ws.Cells(i + 1, j).Height - .Height) / 2
                End With
                Application.CutCopyMode = False
            End If
        Next j
    Next i
End Sub

halecs93 · 16 Août 2023

Merci... curieusement, lorsque je lance la macro en étant sur la feuil1 je rencontre une erreur 400... alors

fanch55 à dit:

Bonjour à tous,
Codes proposés :

VB:

Sub EffacerImages()
    Dim ws As Worksheet
    Dim shp As Shape
   
    ' Spécifiez la feuille sur laquelle vous souhaitez supprimer les images
    Set ws = ThisWorkbook.Sheets("Feuil1")
   
    ' Parcourez toutes les formes (images) sur la feuille et supprimez-les
    For Each shp In ws.Shapes
        If shp.Type = msoPicture Then shp.Delete
    Next shp
End Sub

Sub InsérerImagesModifié()
    Dim ws As Worksheet
    Dim wsImages As Worksheet
    Dim i As Integer, j As Integer
    EffacerImages
   
    ' Définir la feuille de calcul à utiliser
    Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez "Feuil1" par le nom de votre feuille
    Set wsImages = ThisWorkbook.Sheets("Feuil2") ' Remplacez "Feuil2" par le nom de la feuille contenant les images
   
    ' Parcours des lignes avec les noms de notes de musique
    For i = 5 To 13 Step 2 ' Lignes B5, B7, B9, B11, B13
        For j = 2 To 8 ' Colonnes B à H
            Dim nomImage As String
            nomImage = ws.Cells(i, j).Value
           
            ' Chercher l'image correspondante dans la feuille "Feuil2"
            Dim imgShape As Shape
            On Error Resume Next
            Set imgShape = wsImages.Shapes(nomImage)
            On Error GoTo 0
           
            ' Si l'image est trouvée, copier et coller dans la feuille "Feuil1"
            If Not imgShape Is Nothing Then
                imgShape.Copy
                ws.Paste Destination:=ws.Cells(i + 1, j)
                With ws.Shapes(ws.Shapes.Count)
                    .Left = ws.Cells(i + 1, j).Left + (ws.Cells(i + 1, j).Width - .Width) / 2
                    .Top = ws.Cells(i + 1, j).Top + (ws.Cells(i + 1, j).Height - .Height) / 2
                End With
                Application.CutCopyMode = False
            End If
        Next j
    Next i
End Sub

que si je lance la macro de la feuil2, cela fonctionne.... une idée ?

fanch55 · 16 Août 2023

Testez avec le classeur original modifié ci-joint .

halecs93 · 16 Août 2023

fanch55 à dit:
Testez avec le classeur original modifié ci-joint .

Merci.... et cependant toujours cette erreur 400

RyuAutodidacte · 16 Août 2023

Re et bonjour à tous,
@halecs93 il est ou le code de "insérerimagesmodifié"
sinon si l'insertion fini par une shape sélectionner, alors faire suivre ce code une fois l'image inséré :

VB:

Sub selectedShape()
Dim Rg As Range
Set Rg = ActiveSheet.Range(Selection.TopLeftCell.Address)
    With ActiveSheet.Shapes(Selection.Name)
        .Left = Rg.Left + (Rg.Width - .Width) / 2
        .Top = Rg.Top + (Rg.Height - .Height) / 2
    End With
End Sub

Supp :
il est ou le code de "insérerimagesmodifié"

autant pour moi je viens de le trouver

Dranreb · 16 Août 2023

Apparemment la méthode Paste ne renvoie pas le Shape collé mais essaie de le sélectionner (vieux système, dommage), ce qui implique que la feuille destinatrice soit active.
Le bon coté c'est qu'au lieu de Set Shp = Wsh.Shapes(Wsh.Shapes.Count),
on devrait pouvoir faire Set Shp = Selection

halecs93 · 16 Août 2023

Dranreb à dit:
Apparemment la méthode Paste ne renvoie pas le Shape collé mais essaie de le sélectionner (vieux système, dommage), ce qui implique que la feuille destinatrice soit active.
Le bon coté c'est qu'au lieu de Set Shp = Wsh.Shapes(Wsh.Shapes.Count),
on devrait pouvoir faire Set Shp = Selection

Là, ça devient incompréhensible pour moi

RyuAutodidacte · 16 Août 2023

intégré dans la sub modifié, par contre ta sub tu peux la mettre directement dans le module et non dans la feuille :

VB:

Sub InsérerImagesModifié()
    Dim ws As Worksheet
    Dim wsImages As Worksheet
    Dim i As Integer, j As Integer
  
    ' Définir la feuille de calcul à utiliser
    Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez "Feuil1" par le nom de votre feuille
    Set wsImages = ThisWorkbook.Sheets("Feuil2") ' Remplacez "Feuil2" par le nom de la feuille contenant les images
   ws.Select
  
    ' Parcours des lignes avec les noms de notes de musique
    For i = 5 To 13 Step 2 ' Lignes B5, B7, B9, B11, B13
        For j = 2 To 8 ' Colonnes B à H
            Dim nomImage As String
            nomImage = ws.Cells(i, j).Value
          
            ' Chercher l'image correspondante dans la feuille "Feuil2"
            Dim imgShape As Shape
            On Error Resume Next
            Set imgShape = wsImages.Shapes(nomImage)
            On Error GoTo 0
          
            ' Si l'image est trouvée, copier et coller dans la feuille "Feuil1"
            If Not imgShape Is Nothing Then
                imgShape.Copy
                ws.Paste Destination:=ws.Cells(i + 1, j)
                With Selection.ShapeRange
                    .Left = ws.Cells(i + 1, j).Left + (ws.Cells(i + 1, j).Width - .Width) / 2
                    .Top = ws.Cells(i + 1, j).Top + (ws.Cells(i + 1, j).Height - .Height) / 2
                End With
                Application.Goto ws.Cells(i + 1, j)
'                Application.CutCopyMode = True
            End If
        Next j
    Next i
End Sub

Effectuez une recherche sur Excel Downloads...

XL 2016 Centrer Images

halecs93

XLDnaute Impliqué

Pièces jointes

RyuAutodidacte

XLDnaute Impliqué

halecs93

XLDnaute Impliqué

halecs93

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

halecs93

XLDnaute Impliqué

fanch55

XLDnaute Barbatruc

halecs93

XLDnaute Impliqué

fanch55

XLDnaute Barbatruc

Pièces jointes

halecs93

XLDnaute Impliqué

RyuAutodidacte

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

halecs93

XLDnaute Impliqué

RyuAutodidacte

XLDnaute Impliqué

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums