VBA : Insertion d'image dans des cellules fusionnées

Question

Je ne peux pas vous joindre le fichier en question car il est trop confidentiel donc je vais essayer d'être le plus clair possible. Dans un fichier Excel, j'ai une feuille nommée "FichePanne". Les collaborateurs y vont pour remplir cette fiche, appuient sur un bouton "Save" et une instance de cette fiche de panne est créée sur un emplacement réseau. Dans cette fiche de panne, on a la possibilité d'appuyer sur un bouton "Ajouter une photo". Le bouton active la macro suivante : Sub AjouterPhotoAGauche() Dim ws As Worksheet Dim imgPath As String Dim imgPathNew As String Dim imgTop As Double Dim imgLeft As Double Dim imgWidth As Double Dim imgHeight As Double Dim imgDescription As String Dim sharePointFolder As String Dim imgName As String ' Spécifie le nom de la feuille de travail Set ws = ThisWorkbook.Sheets("FichePanne") If ws.Range("F12").Value = "#_#XXX##_YY###_ZZ##" Or ws.Range("W9").Value = "01.01.20" Then MsgBox "Remplissez les autres champs avant (KKS, Date, heure) !" Exit Sub End If ' Demande la description de la photo via une boîte de dialogue imgDescription = InputBox("Entrez une description courte de la photo (sans espaces) :", "Description de la photo") ' Vérifie si l'utilisateur a annulé la boîte de dialogue If imgDescription = "" Then MsgBox "L'opération a été annulée." Exit Sub End If ' Vérifie si la description contient des espaces If InStr(imgDescription, " ") &gt; 0 Then MsgBox "La description ne doit pas contenir d'espaces. Veuillez entrer une description courte sans espaces." Exit Sub End If ' Affiche la boîte de dialogue pour sélectionner une image imgPath = Application.GetOpenFilename(FileFilter:="Images (*.jpg;*.jpeg;*.gif;*.bmp;*.png), *.jpg;*.jpeg;*.gif;*.bmp;*.png", Title:="Sélectionnez une image") ' Vérifie si l'utilisateur a annulé la boîte de dialogue If imgPath = "Faux" Then MsgBox "L'opération a été annulée." Exit Sub End If ' Renomme le fichier imgPathNew = ws.Range("L3") & "_" & imgDescription & "." & GetFileExtension(imgPath) FileCopy imgPath, imgPathNew Kill imgPath ' Spécifie la position de l'image imgTop = ws.Range("A31:O31").Top imgLeft = ws.Range("A31:O31").Left imgWidth = ws.Range("A31:O48").Width imgHeight = ws.Range("A31:O48").Height ' Insère l'image dans la feuille de travail à la position spécifiée ' Utilise directement le chemin renommé pour l'insertion Dim pic As Shape Set pic = ws.Shapes.AddPicture(fileName:=imgPathNew, LinkToFile:=msoFalse, SaveWithDocument:=msoCTrue, Left:=imgLeft, Top:=imgTop, Width:=imgWidth, Height:=imgHeight) pic.LockAspectRatio = msoFalse ' Insère la description de la photo dans la cellule E49 ws.Range("E49").Value = imgDescription ' Emplacement du dossier SharePoint 'sharePointFolder = "MON_LIEN" ' Définit le nom de fichier pour la photo imgName = ws.Range("L3") & "_" & imgDescription MsgBox "Pour le moment, la photo ne s'enregistre pas seule sur le SharePoint. Enregistrez-la manuellement avec le nom suivant : " & imgName End Sub Malheureusement, de temps en temps, une erreur apparaît : "La valeur tapée est en dehors des limites". Donc, je sélectionne toutes les lignes et colonnes, en cliquant sur "Hauteur de cellule" ou "Largeur de cellules", j'ai une valeur affichée, je fais juste "Enter", sans changer les valeurs et mon code fonctionne. La feuille est protégée donc personne ne peut changer les hauteurs de lignes et largeurs de colonnes. Je ne comprends pas comment des valeurs peuvent changer toutes seules, surtout qu'en réel, aucune taille ne change. Les collaborateurs utilisent 2-3 fois le fichier et il devient inutilisable. Quelqu'un aurait une solution ou une alternative possible pour mon code svp ? Cela viendrait de phénomènes/bugs sur Excel ? je sais que ce n'est pas le programme le plus fiable au monde mais quand même. Je vous remercie d'avance...

X Cellus · Accepted Answer

Le souci vient que ton LockAspectRatio vient après le formatage de la largeur et de la hauteur de l'image que tu ajoutes. C'est pour cela que je n'utilise jamais cette manière d'ajouter une image avec les propriétés qui sont intégrées directement entre les parenthèses. Si une des valeurs de taille de l'image, par exemple la largeur de celle-ci doit s'adapter fortement au format du Range, cela va contraidre le ratio largeur/hauteur à s'adapter en conséquence. Et on ne sera plus dans un rapport 100/100 entre la largeur souhaitée et la longueur souhaité. Deux possibilités pour y remédier. Soit passer et le plus facile par un ActiveSheet.Pictures.Insert(chemin & nomd'image avec extension). Name = nomd'image With ActiveSheet.Shapes(nomd'image) .Left = . Top = . LockAspectRatio=msoFalse Et ensuite le code hauteur puis largeur End with L'autre insérer l'image dans un cadre prédifini comme un rectangle, ce qui va la forcer à respecter les tailles de ce rectangle...

X Cellus · Accepted Answer

A nouveau,

Voici la deuxième solution adaptée à tes cellules fusionnées. On utilise un formulaire, voir ci-dessous.

Celui comporte un contrôle Image et trois boutons de commande, l'un pour chercher une image dans un dossier, celle-ci va apparaître dans le contrôle Image. Le deuxième bouton permet d'insérer l'image affichée dans la cellule ou les cellules fusionnées. Le troisième permet de refermer le formulaire. Un contrôle Label entre le contrôle Image et le premier bouton permet d'afficher éventuellement une information. Voici les codes des contrôles du formulaire.

Public xRecherche
Private Sub CommandButton1_Click()
    'Cette fonction récupère dans une variable le résultat d'une boite de dialogue OUVRIR
    ' en recherchant des images d'extension jpg et png
    xRecherche = Application.GetOpenFilename("Fichiers acceptés,*.jpg;*.png")
    If xRecherche = False Then MsgBox "Annulé": Exit Sub
        xChemin = CurDir(xRecherche) & "\"
        xFichier = Mid(xRecherche, Len(xChemin) + 1)
    Maj = UCase(xRecherche)
If Not Maj Like "*.PNG" Then Image1.Picture = LoadPicture(xRecherche) Else Label1.Caption = "Image PNG acquise"
End Sub

Private Sub CommandButton2_Click()
'Pour une cellule non fusionnée
'Adr = ActiveCell.Address
'H = Range(Adr).Height
'W = Range(Adr).Width
'Pour une cellule fusionnée
Adr = ActiveCell.Address
H = Range(ActiveCell.Address).MergeArea.Height
W = Range(ActiveCell.Address).MergeArea.Width
'Test de la présence d'une image déjà dans la cellule
On Error Resume Next
If ActiveSheet.Shapes("Img" & Adr).Width > 0 Then ActiveSheet.Shapes("Img" & Adr).Delete
With Feuil1.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Top, W, H)
    .Name = "Img" & Adr
    .Fill.UserPicture xRecherche
    .Fill.Transparency = 0    ' de o à 1 (1 etant completement transparent)
    .Shadow.Visible = msoFalse  'aucune ombre
    .Line.Visible = msoFalse    'aucun trait
End With
End Sub
Private Sub CommandButton3_Click()
Unload Me
End Sub

Et le résultat ci dessous.

Ne pas oublier de lancer le formulaire à partir d'une macro dans un module simple.

Sub AppelUSF()
UserForm1.Show
End Sub

Si cela te convient merci de clôturer cette demande ou faire un retour.