Dimension import image

Bonjour à tous,

J'ai la macro suivante qui intègre automatiquement mes photos selon nom du fichier et nom des cellules :

Sub InsererPic1()
Dim snom As String
Dim i As Long
' Boucle pour balayer les lignes 2 à 4
 For i = 2 To 10
' Définir le nom de l'image à insérer
   snom = Range("A" & i).Value
' Se placer dans la cellule
   Range("B" & i).Select
' Insérer l'image
   ActiveSheet.Pictures.Insert(snom & ".jpg").Select
    ' Modification de la hauteur de la ligne
   Rows(i & ":" & i).RowHeight = 80
    ' Modification Position de Image
     Selection.ShapeRange.ScaleWidth 0.1652777838, msoFalse, msoScaleFromTopLeft
      Selection.ShapeRange.ScaleHeight 0.1652778622, msoFalse, msoScaleFromTopLeft
      Selection.ShapeRange.IncrementLeft 8
      Selection.ShapeRange.IncrementTop 5
  Next i
End Sub

La hauteur de mes cellules sont redimensionnées à 80 px.

Ce que je souhaite, c'est que les visuels qui sont importés fassent également 80px de hauteur, et que l'homothétie soit respectée.

Pourriez-vous m'expliquer comment faire svp ?

PS : j'ai besoin que cela fonctionne avec Excel Mac 2011 et Excel PC 2013 svp

Bonjour

J'ai beau torturé la macro avec ce que je trouve sur le forum, rien ne fonctionne :'(

Please help !

Salut,

Voici une proposition

Cela te convient ?

Sub InsererPic1()
Dim snom As String
Dim i As Long
Dim Emplacement As Range
' Boucle pour balayer les lignes 2 à 10
For i = 2 To 10
    ' Définir le nom de l'image à insérer
    snom = Range("A" & i).Value
    ' Se placer dans la cellule
     Range("B" & i).Select
    Rows(i & ":" & i).RowHeight = 80
    Set Emplacement = ActiveCell.MergeArea
    ' Insérer l'image
    ActiveSheet.Pictures.Insert(snom & ".jpg").Select
    ' Modification de la hauteur de la ligne
    With Selection.ShapeRange
        .Left = Emplacement.Left
        .Top = Emplacement.Top
        .LockAspectRatio = msoTrue
        .Height = Emplacement.Height
    End With
 Next i
End Sub

Hello,

désolé du retard de ma réponse mais c'est parfait !

Merci beaucoup

Pas de problème.

Ravi d'avoir pu t'aider.

Bonjour,

de retour sur ce sujet... Car la macro ne fonctionne pas sur Excel 2016 (PC avec Win10)

Elle me rempli bien les cellules en rouge mais ne m'insère pas les images :/

Comment ça se fait ?

Y'a t'il une solution svp ?

Sub InsererPic2()
Const cExtensions = "jpg;png;tif;gip"
Const cPathImages = "Images"
Dim sPath As String
Dim snom As String, sEAN As String
Dim i As Long, iExtension As Long
Dim Emplacement As Range
Dim oFS As Object
Dim booFileOK As Boolean
Dim aExtensions() As String
aExtensions = Split(cExtensions, ";")
Set oFS = CreateObject("Scripting.FileSystemObject")
sPath = ThisWorkbook.Path & "\" & cPathImages & "\"
' Boucle pour balayer les lignes 2 à 150
For i = 2 To 150
' DÈfinir le nom de l'image ‡ insÈrer
sEAN = Range("C" & i).Value
' Se placer dans la cellule
Range("S" & i).Select
Rows(i & ":" & i).RowHeight = 80
Set Emplacement = ActiveCell.MergeArea
'Boucle sur l'extension pour trouver l'image
booFileOK = False
For iExtension = 0 To UBound(aExtensions)
If oFS.Fileexists(sPath & snom & "." & aExtensions(iExtension)) Then
snom = sEAN & "." & aExtensions(iExtension)
booFileOK = True
End If
Next
If booFileOK Then
ActiveSheet.Shapes.AddPicture sPath & snom & ".jpg", msoFalse _
, msoCTrue _
, Emplacement.Left _
, Emplacement.Top _
, Emplacement.Width _
, Emplacement.Height
Else
Emplacement.Interior.Color = vbRed
End If
Next i
'On fait la mÈnage
Set oFS = Nothing
End Sub

Salut,

A première vue, voici les deux cas me viennent à l'esprit.

1er cas : tu as un pb de chemin est la valeur de la variable booFileOK est toujours égale à fausse. Ce qui explique les cellules rouges

2eme cas : la variable booFileOK peut-être égale à vrai mais dans ce cas, si l'extension n'est pas jpg ca ne marche pas car ta variable snom contient déjà l'extension et tu rajoutes derrière ".jpg"

If booFileOK Then
ActiveSheet.Shapes.AddPicture sPath & snom & ".jpg", msoFalse _
, msoCTrue _
, Emplacement.Left _
, Emplacement.Top _
, Emplacement.Width _
, Emplacement.Height

Jers