Image dans une cellule

[GBB]

Bonjour,

Je suis nouveau sur ce forum et je voudrais savoir si une cellule contient une image ou un dessin, ou inversement si l'on connait le nom d'un dessin de savoir dans quelle cellule il se trouve.

J'ai une macro qui recopie des cellules d'une feuille à une autre (vierge au départ) et qui adapte automatiquement la taille de la cellule copié à son contenu. Sa marche très bien avec les textes, mais pas du tout avec un dessin.

Par avance merci.

Salutations

 

[MichelXld]

Re : Image dans une cellule

bonjour

ou inversement si l'on connait le nom d'un dessin de savoir dans quelle cellule il se trouve.

Tu peux utiliser les propriétés TopLeftCell et BottomRightCell

Sub PositionFormeAutomatique()
    Dim Shp As Shape
    
    'Spécifie la forme dans la Feuil1
    Set Shp = Feuil1.Shapes("NomForme")
    MsgBox Shp.TopLeftCell.Address & ":" & Shp.BottomRightCell.Address
End Sub

Bon après midi
MichelXld

 

[GBB]

Re : Image dans une cellule

OK merci ca répond tout à fait à mon problème

J' ai rajouté à ton code une boucle while qui me permet de faire rentre le dessin dans une seule ligne

Sub PositionFormeAutomatique()
    Dim Shp As Shape
    Dim Sh As Shape
    Dim hauteur_ligne As Integer
    
' on recherche tous les dessins présent dans la feuille
For Each Sh In Worksheets("DOC").Shapes
    If Sh.Type = msoPicture Then
        Nom_dessin = Sh.Name
        'on spécifie la forme dans la feuille et on trouve sur quelles cellules il s'etend
        Set Shp = ActiveSheet.Shapes(Nom_dessin)
        Cellule_debut_dessin = Shp.TopLeftCell.Address
        Cellule_fin_dessin = Shp.BottomRightCell.Address
        ' On augmente la hauteur de la ligne jusqu'à ce que le dessin rentre dans une seule
        While Cellule_debut_dessin <> Cellule_fin_dessin
                Range(Cellule_debut_dessin).Select
                hauteur_ligne = ActiveCell.Height
                Range(Cellule_debut_dessin).RowHeight = hauteur_ligne + 10
                Set Shp = ActiveSheet.Shapes(Nom_dessin)
                Cellule_debut_dessin = Shp.TopLeftCell.Address
                Cellule_fin_dessin = Shp.BottomRightCell.Address
        Wend
    End If
Next

End Sub

Salutatons

GBB