Macro pour insérer des images avec des extensions différentes

Bonjour à tous,

je viens vers vous afin de m'apporter un peu d'aide.

Voici une macro qui fonctionne parfaitement mais elle ne me permet que d'insérer des images au format JPG.

Je souhaiterais pouvoir également insérer des images aux formats JPEG, PNG et BMP.

J'ai bien essayé de modifier la ligne avec la commande "sPathFic" mais sans succès... je dois très certainement m'emmêler les pinceaux avec la fin de la commande :(

Malgré les recherches effectuées, je n'ai rien trouvé pour ajouter les extensions souhaitées. J'ai bien trouvé d'autres macros mais rien ne m'indique qu'elles supportent toutes les extensions dont j'ai besoin.

Dans la mesure du possible, je préfère modifier cette macro qui m'apporte entière satisfaction :)

Sub Insérer_Photo()
  Dim ws As Worksheet, rng As Range
  Set ws = ActiveSheet
  ws.Unprotect Password:="7601"
  Dim sPathFic As String
  Dim Img As Object
  ' Choix du fichier directement dans le dossier choisi
  sPathFic = ChoixFichier("Z:\B-TC.2K3.3.1 - Service de cour et triage\SERVICE DE COUR\Archive Constatation écart\Photos", "CHOIX de l'IMAGE", "Image (*.jpg), *.jpg")
  ' Evite les erreurs quand on ferme la fenêtre ou quand on fait Annuler
  If sPathFic = "" Then Exit Sub
  ' Sélectionner la cellule ou placer la photo
  ActiveSheet.Range("AK4").Select
  Set Img = ActiveSheet.Pictures.Insert(sPathFic)

End Sub

Bonjour David,

Un changement de fonction à faire dans ce cas là

Sub Insérer_Photo()
  Dim ws As Worksheet, rng As Range
  Set ws = ActiveSheet
  'ws.Unprotect Password:="7601"
  Dim sPathFic As String
  Dim Img As Object
  ' Choix du fichier directement dans le dossier choisi
  sPathFic = ChoixImage("Z:\B-TC.2K3.3.1 - Service de cour et triage\SERVICE DE COUR\Archive Constatation écart\Photos")
  ' Evite les erreurs quand on ferme la fenêtre ou quand on fait Annuler
  If sPathFic = "" Then Exit Sub
  ' Sélectionner la cellule ou placer la photo
  ActiveSheet.Range("AK4").Select
  Set Img = ActiveSheet.Pictures.Insert(sPathFic)
End Sub

Function ChoixImage(DefaultPath As String)
  Dim fd As FileDialog, TabFilter() As String
  Dim Ind As Integer
  ' Initialiser les variables
  If Right(DefaultPath, 1) <> "\" Then DefaultPath = DefaultPath & "\"
  ' Initialiser l'intance du dialogue
  Set fd = Application.FileDialog(msoFileDialogFilePicker)
  With fd
    .Filters.Clear
    .Filters.Add "Image", "*.jpg, *.png, *.bmp"
    .Title = "CHOIX de L'IMAGE"
    .InitialFileName = DefaultPath
    If .Show = -1 Then
      ChoixImage = fd.SelectedItems(1)
    End If
  End With
  Set fd = Nothing
End Function

A+

Ah oui là j'étais loin du compte....

Cela fonctionne à merveille mais maintenant j'ai des messages de débogage sur ma macro de suppression d'images... :(

l'erreur est sur les lignes "if not intersect" .... Je ne vois pas en quoi cela n'est pas fonctionnel....

Sub EffaceImagesDansZone()
    Dim ws As Worksheet, rng As Range
    Set ws = ActiveSheet 'ou Worksheets("Feuil1") par exemple
        ws.Unprotect Password:="7601"
    Dim Image
    Application.ScreenUpdating = False
    For Each Image In ActiveSheet.Shapes
        If Not Intersect(Image.TopLeftCell, [AK4:BC43]) Is Nothing And _
           Not Intersect(Image.BottomRightCell, [AK4:BC43]) Is Nothing Then Image.Delete
    Next Image
    ws.Protect Password:="7601"
End Sub

Le problème est aléatoire mais survient quasi à chaque fois que l'on a inséré une photo et que l'on veut la supprimer directement....