Insertion d'image automatique

Bonjour le forum,

je viens vers vous car je seche complétement....

J'ai créé un fichier pour un rapport de visite de chantier et j'aimerai que, en cliquant sur un bouton, les images qui portent un suffixe précis se chargent dans le fichier à des endroits précis.

J'ai donc un sheet "report preview" qui accueillera ces images.

les images se trouvent bien dans le répertoire défini dans la macro d'enregistrement et portent bien les nom spécifique (mais elles ne sont pas toutes obligatoire)

j'ai déjà créé une base mais je n'arrive pas, j'ai essayé en utilisant les nom de cellules sous forme de A73:G83 (par exemple), j'ai essayé en créant des rectangle nommé avec le suffixe (_SP par exemple) mais non, Dans le fichier joint j'essaye avec des zone de texte nommées avec le suffixe mais les images n'en font qu'as leur têtes. Pourriez-vous m'aider svp

le répertoire est C:\EF site inspection report\Report Nr Test intregration pictures

Voici le zip qui contient l'excel et les photos

d'avance un grand merci.

Bonjour,

Après avoir aussi demandé de m'aider à ChatGPT (qui as bien galéré à me donner une solution), j'ai aussi demandé à DeepSeek avec les même paramètre, après quelques coup d'essais voici une solution :

Sub Insertion_des_photos()
    Dim wsReport As Worksheet
    Dim wsInspection As Worksheet
    Dim RepertoryPath As String
    Dim missingImages As String
    Dim imageFound As Boolean

    ' Définir les feuilles de travail
    Set wsInspection = ThisWorkbook.Sheets("Site inspection report")
    Set wsReport = ThisWorkbook.Sheets("Report Preview")

    ' Créer le chemin du répertoire
    RepertoryPath = "C:\EF site inspection report\Report Nr " & wsInspection.Range("B2").Text & "\"

    ' Vérifier si le répertoire existe
    If Dir(RepertoryPath, vbDirectory) = "" Then
        MsgBox "Le répertoire n'existe pas : " & RepertoryPath, vbExclamation
        Exit Sub
    End If

    ' Supprimer les images existantes dans les formes nommées
    Call DeleteExistingPictures(wsReport)

    ' Variables pour suivre les images manquantes
    missingImages = ""

    ' Insérer les images selon les spécifications
    ' Photo _SP
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_SP.jpg", "Photo_SP", missingImages)

    ' Photos _S1 à _S4
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_S1.jpg", "Photo_S1", missingImages)
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_S2.jpg", "Photo_S2", missingImages)
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_S3.jpg", "Photo_S3", missingImages)
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_S4.jpg", "Photo_S4", missingImages)

    ' Photo _L
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_L.jpg", "Photo_L", missingImages)

    ' Photo _IP
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_IP.jpg", "Photo_IP", missingImages)

    ' Photo _WC
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_WC.jpg", "Photo_WC", missingImages)

    ' Photos _QW1 à _QW4
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_QW1.jpg", "Photo_QW1", missingImages)
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_QW2.jpg", "Photo_QW2", missingImages)
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_QW3.jpg", "Photo_QW3", missingImages)
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_QW4.jpg", "Photo_QW4", missingImages)

    ' Photos _DS1 à _DS4
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_DS1.jpg", "Photo_DS1", missingImages)
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_DS2.jpg", "Photo_DS2", missingImages)
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_DS3.jpg", "Photo_DS3", missingImages)
    imageFound = InsertImageNamedShape(wsReport, RepertoryPath, "*_DS4.jpg", "Photo_DS4", missingImages)

    ' Message de confirmation
    If missingImages = "" Then
        MsgBox "Toutes les images ont été insérées avec succès.", vbInformation
    Else
        MsgBox "Les images ont été insérées, mais les suivantes n'ont pas été trouvées : " & vbNewLine & missingImages, vbInformation
    End If
End Sub

Function InsertImageNamedShape(ws As Worksheet, folderPath As String, imagePattern As String, shapeName As String, ByRef missingImages As String) As Boolean
    Dim imgFile As String
    Dim img As Picture
    Dim shp As Shape
    Dim fullPath As String
    Dim imgRatio As Double, shapeRatio As Double

    ' Trouver le fichier image
    imgFile = Dir(folderPath & imagePattern)

    If imgFile <> "" Then
        fullPath = folderPath & imgFile

        ' Vérifier que le fichier existe vraiment
        If Dir(fullPath) = "" Then
            If missingImages <> "" Then missingImages = missingImages & ", "
            missingImages = missingImages & Replace(imagePattern, "*", "")
            InsertImageNamedShape = False
            Exit Function
        End If

        ' Vérifier si la forme nommée existe
        On Error Resume Next
        Set shp = ws.Shapes(shapeName)
        On Error GoTo 0

        If shp Is Nothing Then
            If missingImages <> "" Then missingImages = missingImages & ", "
            missingImages = missingImages & "Forme " & shapeName & " manquante"
            InsertImageNamedShape = False
            Exit Function
        End If

        ' Insérer l'image avec gestion d'erreur
        On Error Resume Next
        Set img = ws.Pictures.Insert(fullPath)
        On Error GoTo 0

        If img Is Nothing Then
            If missingImages <> "" Then missingImages = missingImages & ", "
            missingImages = missingImages & Replace(imagePattern, "*", "")
            InsertImageNamedShape = False
            Exit Function
        End If

        ' Calculer les ratios
        imgRatio = img.Width / img.Height
        shapeRatio = shp.Width / shp.Height

        ' Positionner et redimensionner l'image selon la forme nommée
        With img
            ' Donner le même nom que la forme cible
            .Name = "Img_" & shapeName
            .ShapeRange.LockAspectRatio = msoTrue

            ' Adapter selon le ratio
            If imgRatio > shapeRatio Then
                ' L'image est plus large que la forme -> ajuster à la largeur
                .Width = shp.Width
                .Left = shp.Left
                .Top = shp.Top + (shp.Height - .Height) / 2
            Else
                ' L'image est plus haute que la forme -> ajuster à la hauteur
                .Height = shp.Height
                .Left = shp.Left + (shp.Width - .Width) / 2
                .Top = shp.Top
            End If
        End With

        InsertImageNamedShape = True
    Else
        ' Ajouter à la liste des images manquantes
        If missingImages <> "" Then missingImages = missingImages & ", "
        missingImages = missingImages & Replace(imagePattern, "*", "")
        InsertImageNamedShape = False
    End If
End Function

Sub DeleteExistingPictures(ws As Worksheet)
    Dim shp As Shape
    Dim pic As Picture

    ' Supprimer toutes les images qui commencent par "Img_"
    For Each shp In ws.Shapes
        If TypeName(shp) = "Picture" Then
            If Left(shp.Name, 4) = "Img_" Then
                shp.Delete
            End If
        End If
    Next shp
End Sub

Je place ici la solution afin qu'elle puisse servir à d'autre. Cette solution implique de créer des formes afin de définir les zones dans lesquelles les images serons insérée. Cette solution ne prend pas en compte une rotation de l'image mais bien le redimentionnement de celles-ci.

Je m'excuse si éventuellement une personne était occupée avec mon soucis d'avoir pris les devant et d'avoir demandé ailleur.