Bonjour le forum,
Je suis à la recherche d'un code me permettant d'insèrer des images dans une cellule.
Jusque là, rien de trop difficile..
Le hic, c'est que mes références qui se trouvent en colonne A n'ont pas tout à fait les mêmes noms que mes Jpeg qui se trouve dans mon répertoire.
Je m'explique par un exemple:
une référence dans cellule A1 : B4805
mon image dans mon répertoire : B4805_251007.
Ma réference est toujours composé de 5 caractères qui compose les 5 premiers caractères du nom de mon image.
Les caractères qui suivent mes 5 premiers caractères changent tous les mois.
Donc mon image le mois prochain s'appellera pê B4805_101107
Voici le code que j'ai trouvé et qui fonctionne en suposant que mes 5 premiers caractères sont tjrs suivis de _251007
Merci de m'aider,
David
Sub IntegrationPhoto()
Dim derligne As Integer, i As Integer
Dim chemin As String
Dim image As Object
For Each image In Sheets("Main").Shapes
If image.Name <> "Button 12" Then image.Delete
Next image
derligne = Range("Main!a65536").End(xlUp).Row
For i = 2 To derligne
If Sheets("Main").Range("d" & i) = "x" Then
With Sheets("Main").Range("A" & i)
If Not .Value = "" Then 'gestion cellule vide
chemin = ActiveWorkbook.Path & "\" & .Text & "_251007" & ".jpg"
Set image = ActiveSheet.Pictures.Insert(chemin)
On Error Resume Next
If image.ShapeRange.Height > image.ShapeRange.Width Then
With image.ShapeRange
.LockAspectRatio = msoTrue
.Left = Sheets("Main").Range("b" & i).Left
.Top = Sheets("Main").Range("b" & i).Top
.Height = Sheets("Main").Range("b" & i).Height
'.Width = Sheets("feuil1").Range("b" & i).Width
End With
Else
With image.ShapeRange
.LockAspectRatio = msoTrue
.Left = Sheets("Main").Range("b" & i).Left
.Top = Sheets("Main").Range("b" & i).Top
'.Height = Emplacement.Height
.Width = Sheets("Main").Range("b" & i).Width
End With
End If
End If
End With
End If
Next i
End Sub
Je suis à la recherche d'un code me permettant d'insèrer des images dans une cellule.
Jusque là, rien de trop difficile..
Le hic, c'est que mes références qui se trouvent en colonne A n'ont pas tout à fait les mêmes noms que mes Jpeg qui se trouve dans mon répertoire.
Je m'explique par un exemple:
une référence dans cellule A1 : B4805
mon image dans mon répertoire : B4805_251007.
Ma réference est toujours composé de 5 caractères qui compose les 5 premiers caractères du nom de mon image.
Les caractères qui suivent mes 5 premiers caractères changent tous les mois.
Donc mon image le mois prochain s'appellera pê B4805_101107
Voici le code que j'ai trouvé et qui fonctionne en suposant que mes 5 premiers caractères sont tjrs suivis de _251007
Merci de m'aider,
David
Sub IntegrationPhoto()
Dim derligne As Integer, i As Integer
Dim chemin As String
Dim image As Object
For Each image In Sheets("Main").Shapes
If image.Name <> "Button 12" Then image.Delete
Next image
derligne = Range("Main!a65536").End(xlUp).Row
For i = 2 To derligne
If Sheets("Main").Range("d" & i) = "x" Then
With Sheets("Main").Range("A" & i)
If Not .Value = "" Then 'gestion cellule vide
chemin = ActiveWorkbook.Path & "\" & .Text & "_251007" & ".jpg"
Set image = ActiveSheet.Pictures.Insert(chemin)
On Error Resume Next
If image.ShapeRange.Height > image.ShapeRange.Width Then
With image.ShapeRange
.LockAspectRatio = msoTrue
.Left = Sheets("Main").Range("b" & i).Left
.Top = Sheets("Main").Range("b" & i).Top
.Height = Sheets("Main").Range("b" & i).Height
'.Width = Sheets("feuil1").Range("b" & i).Width
End With
Else
With image.ShapeRange
.LockAspectRatio = msoTrue
.Left = Sheets("Main").Range("b" & i).Left
.Top = Sheets("Main").Range("b" & i).Top
'.Height = Emplacement.Height
.Width = Sheets("Main").Range("b" & i).Width
End With
End If
End If
End With
End If
Next i
End Sub