Photo dans un shape

Bonjour à tous,

Dans ce code, j'ai une photo qui s'affiche dans le 'shape' Image1
tout fonctionne bien... j’essaie d'ajouter de l'ombrage sous la photo en ajoutant cette ligne mais sans succès,
quelqu'un aurait une idée de mon problème ?

Sheets("Etiquette statue").Image1(nf).Shadow.Type = msoShadow21

    'Etiquette 1

    ND = Sheets("Etiquette statue").Range("A2")
    ND2 = Right(Sheets("Etiquette statue").Range("A2"), 8)
    If ND <> "" Then                                              ' vérifie condition  
        chemin = Sheets("Paramètre").Range("B2").Value            ' chemin du répertoire principal 
        nf = chemin & "\Photo\" & ND & "\Photo\Vignette.jpg"
        If Dir(nf) <> "" Then
            Sheets("Etiquette statue").Image1.Picture = LoadPicture(nf)
            Sheets("Etiquette statue").Image1.PictureSizeMode = fmPictureSizeModeZoom
            Sheets("Etiquette statue").Image1(nf).Shadow.Type = msoShadow21            ' tentative d'ajouter de l'ombre sous la photo
        Else
            Sheets("Etiquette statue").Image1.Picture = Nothing
        End If
    End If

Bonsoir,

partie d'un code d'une application en cours de développement (non sérieusement ? si si , ici !) où je charge une image dans un shape et à l'issue j'y applique une ombre :

    ' la raquette
    Set Raquette = ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\Système\RB.png")
    With Raquette
        .Name = "Raquette"
        .Left = Ox + 195 - .Width / 2
        .Top = 465 + Oy + 10
        .Placement = xlFreeFloating
        With .ShapeRange.Shadow
            .Type = msoShadow21
            .Visible = msoTrue
            .Style = msoShadowStyleOuterShadow
            .Blur = 4
            .OffsetX = 5
            .OffsetY = 5
            .RotateWithShape = msoFalse
            .ForeColor.RGB = RGB(0, 0, 0)
            .Transparency = 0
            .Size = 100
        End With
    End With

A voir chaque ligne pour savoir ce qui vous sera utile.
la ligne SET permet de contrôler le shape "en cours" sans le sélectionner.

@ bientôt

LouReeD

Bonjour Loureed,

merci pour ton aide, je tente d'appliquer ce code... je t'en redonne des nouvelles...

bonne journée

@Loureed, je n'y arrive pas :-(

J'ai tenté avec cette ligne Sheets("Etiquette statue").Image1.Picture.Shadow.Type = msoShadow21 sans succès

quelqu'un aurait une piste, un indice, pour ajouté de l'ombrage à une photo placé dans un 'shape'

Pourquoi Image1 ?

@ bientôt

LouReeD

c'est le nom du 'shape' dans la feuille... il y en a plusieurs (Image1, Image2, Image3, etc)
Le ( ou les ) shape sont placé dans la feuille, et les photos ce colle au shape via vba ( code publié dans mon premier poste )

Bonsoir,

pourquoi ne pas créer le shape en y intégrant directement l'image comme dans mon code ?

Dim MonImage1
Set MonImage1 = ActiveSheet.Pictures.Insert(nf)
With MonImage1.ShapeRange.Shadow
    .Type = msoShadow21
    .Type = msoShadow21 .Visible = msoTrue
    .Style = msoShadowStyleOuterShadow
    .Blur = 4
    .OffsetX = 5
    .OffsetY = 5
    .RotateWithShape = msoFalse
    .ForeColor.RGB = RGB(0, 0, 0)
    .Transparency = 0
    .Size = 100
End With

@ bientôt

LouReeD

@ LouReeD merci de m'aider....

La journée est presque terminé pour moi, demain matin, je vais essayer le code que tu proposes...
Pour ce qui est de placé les shape sur la feuille, ça sera en modifiant les valeurs offset ?

Les OffSet sont dans un "With" du Shadow, donc ils influent sur l'ombre...
Pour le décalage du shape sur la feuille il faut juste prendre l'objet "MonImage1" puis le left et le top :

MonImage1.Left =
MonImage1.Top =

L'avantage de créer un objet "MonImage" et de lui attribuer un shape "en création" directement c'est qu'après il suffit de "parler" de lui dans le code et non pas d'un objet se trouvant sur une feuille etc, MonImage1.Left est plus simple que Activesheet.Shapes("Le nom du shape sous Excel")

Après je ne voudrais pas que cela perturbe trop vos codes ou fichiers... C'est pourquoi un fichier représentatif de votre travail est utile afin de se rendre compte de l'influence et de la possibilité des réponses offertes.

@ bientôt

LouReeD

Bon matin LouReeD

J'ai réussis avec ton code à obtenir le résultat souhaité.... un grand merci

Dans mon fichier, je pouvais supprimer, le shape (et photo) avec cette ligne de code
'Sheets("Etiquette statue").Image1.Picture = Nothing'

Évidemment, ça ne fonctionne plus suite au modification du code, quel serait le code pour effacer ce qui sera MonImage1, MonImage2, MonImage3, etc

merci de ta patience et de ton aide

a titre d'info, voici le code pour une image....

ce code apparait 8 fois dans le module, et adapté pour chaque image....

cette ligne "Sheets("Etiquette statue").Image1.Picture = Nothing" n'est plus fonctionnel....

et je dois trouver le code pour supprimer une image...

Il y a d'autre shape non lié sur la page, ce qui rend impossible de supprimer tout les shape de la page....

ND = Sheets("Etiquette statue").Range("A2")
    If ND <> "" Then
        chemin = Sheets("Paramètre").Range("B2").Value
        nf = chemin & "\Photo\" & ND & "\Photo\Vignette.jpg"
    Dim MonImage1
    Set MonImage1 = ActiveSheet.Pictures.Insert(nf)
    With MonImage1.ShapeRange.Shadow
        .Type = msoShadow21
        .Style = msoShadowStyleOuterShadow
        .Blur = 4
        .OffsetX = 5
        .OffsetY = 5
        .RotateWithShape = msoFalse
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0.7
        .Size = 100

    End With
    MonImage1.Left = 226
    MonImage1.Top = 116
    Else
        Sheets("Etiquette statue").Image1.Picture = Nothing   ' non fonctionnel
    End If

Bon, je commence à croire que je devrai revenir au code de départ, la photo s'ajustait au shape...
Des que le ratio de la photo change, avec le nouveau code c'est difficile de gérer l'emplacement de la photo.... :-(

Sinon pour effacer : MonImage. Delete

Pour les ratios faut voir.

@ bientôt

LouReeD

Bonsoir,

ci joint un fichier :

dans le code mettez en face de URL = le chemin de l'une de vos photos/Images.

Puis cliquez sur le bouton "ajout images", l'images s'ajoute 3 fois en fonction de sa taille avec différentes valeurs pour "le zoom".
C'est juste un fichier pour le test, mais l'image chargée est proportionnelle à l'originale. Ceci grâce à la fonction DimensionImage.

L'autre bouton sert à effacer les images ainsi crées.

On peut très bien l'adapter à votre demande je pense.

@ bientôt

LouReeD

Une autre façon de l'écrire pour la première partie du code :

Sub TestLRD()

    Dim Taille_Img, X, Y, Temp, LeRatio, Url As String, I, myDocument
    Dim MonImage1
    Url = "C:\LOUREED\Pictures\Photos\1.jpg" ' ici mettre votre chemin d'accès aux images
    Taille_Img = DimensionsImage(Url)

    ' si l'image ne représente rien
    If Taille_Img = "" Then Exit Sub

    ' on découpe les dimensions de l'image
    ' en partant du premier caractère on recherche "espace x espace" ce qui va nous donner l'emplacement du premier espace dans la chaine taille
    Temp = InStr(1, Taille_Img, " x ")

    ' la taille de l'image en X est égale à la deuxième valeur de la chaine Taille_Img
    ' donc on extrait à partir de Temp + 3 (l'espace + le x + l'espace) et on retire 1 afin de ne pas avoir une ligne grise à droite et
    ' en bas sur la feuille résultat
    X = Val(Mid(Taille_Img, Temp + 3, Len(Taille_Img))) - 1
    ' on fait pareille pour le Y
    Y = Val(Left(Taille_Img, Temp - 1)) - 1

    For I = 1 To 3
        Set MonImage1 = ActiveSheet.Shapes.AddPicture( _
            "C:\Users\loure.PC-LOUREED\Pictures\Photos Téléphone\Pictures\1.jpg", _
            False, True, 100, 100, X / 10, Y / 10)

        With MonImage1
            With .Shadow
                .Type = msoShadow21
                .Visible = msoTrue
                .Style = msoShadowStyleOuterShadow
                .Blur = 4
                .offsetX = 5
                .offsetY = 5
                .RotateWithShape = msoFalse
                .ForeColor.RGB = RGB(0, 0, 0)
                .Transparency = 0
                .Size = 100
            End With
            .Name = "_LRD" & I
            .Left = 100 * I
            .Top = 200
        End With
    Next I
End Sub

Toujours une taille en fonction de X et Y.

@ bientôt

LouReeD

Bon matin LouReeD

merci d'être encore la
je vais essayer ta proposition... je te laisse connaitre le résultat

@ bientôt

LouReeD