Macro copie image

Bonjour à tous,

Je dispose d'une macro qui me permet d'insérer des images dans une feuille Excel et dans un emplacement précis. Ces images sont redimensionnées en fonction de l'emplacement défini.

Sub InsertionImage()
    Dim Emplacement As Range
    Dim Img As Object
    Dim ShapeObj As Shape

    'Boucle pour supprimer l'ancienne image
    For Each ShapeObj In ActiveSheet.Shapes
        If ShapeObj.Name = "Cible" Then ActiveSheet.Shapes("Cible").Delete
    Next ShapeObj

    If Application.Dialogs(xlDialogInsertPicture).Show Then
        'Définit l'emplacement de l'image
        Set Emplacement = Range("B5:G30")

        Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)

        With Img.ShapeRange
            'Nommer l'image insérée (Pour la supprimer plus facilement ensuite)
            .Name = "Cible"
            .LockAspectRatio = msoFalse
            .Left = Emplacement.Left
            .Top = Emplacement.Top
            .Height = Emplacement.Height
            .Width = Emplacement.Width
        End With

    Else
        MsgBox "Insertion d'image interrompue."
    End If

End Sub

La macro fonctionne bien j'ai juste un petit soucis que je n'arrive pas à résoudre. Je voudrais définir l'emplacement de l'image en fonction d'une plage de cellule nommée c'est à dire par exemple remplacer :

Set Emplacement = Range("B5:G30") par Set Emplacement = Range("Courbe1").

Lorsque je fais cette modification, la macro fonctionne toujours, cependant, l'image insérée n'est pas redimensionnée correctement, elle est plus petite que ce qu'elle devrait être.

Avez-vous une idée d'où pourrait venir le problème et comment y remédier?

Je vous remercie d'avance !

Bonjour,

j'ai fait le test sur un nouveau fichier, et je n'ai pas réussi à reproduire ce problème,

pouvez-vous faire le test avec ce fichier,

Bonjour sabV,

Merci de m'avoir répondu. J'ai fait le test sur ton fichier et effectivement le problème n’apparaît pas. Cependant en regardant ton fichier, j'ai compris d'où venait le problème.

En fait j'avais fusionné la plage de cellule puis j'ai nommé les cellules fusionnées "Courbe1". J'ai constaté dans ton fichier que tu n’avais pas fusionné les cellules de la plage mais que tu les avais juste nommé. J'ai effectué la même chose sur mon fichier et ça fonctionne très bien !

En fait lorsque je nomme par exemple la plage "B2 : D20" ma macro considère qu'il n'y a que la cellule B2 qui est nommée et donc l'image insérée est uniquement redimensionnée en fonction de cette cellule.

Merci encore

bonjour,

je cherche depuis longtemps sur une solution qui ressemble à ton code

sauf que , ton code ouvre le rep image par défaut qui est Images de Bibliothèque alors que dans mon cas je veux que le répertoire par défaut soit mon rep de travail

c.a.d le code que je cherche c'est exactement ton code avec la seule différence le répertoire courant des images

merci pour les personnes qui peuvent m'aider

Bonjour,

une autre solution sans passer par Application.Dialogs(xlDialogInsertPicture)

ChDir "C:\Users\isabelle\Documents\Mes documents\Mes images" 'à adpter
Fname = Application.GetOpenFilename(FileFilter:="Picture Files (*.gif;*.jpg;*.jpeg;*.bmp),*.gif;*.jpg;*.jpeg;*.bmp", Title:="Select Picture")
If Fname <> "" Then
  Set im = ActiveSheet.Pictures.Insert(Fname)
End If

sabV a écrit :

Bonjour,

une autre solution sans passer par Application.Dialogs(xlDialogInsertPicture)

ChDir "C:\Users\isabelle\Documents\Mes documents\Mes images" 'à adpter
Fname = Application.GetOpenFilename(FileFilter:="Picture Files (*.gif;*.jpg;*.jpeg;*.bmp),*.gif;*.jpg;*.jpeg;*.bmp", Title:="Select Picture")
If Fname <> "" Then
  Set im = ActiveSheet.Pictures.Insert(Fname)
End If

merci beaucoup ça marche c'est exactement ce que je cherche