Importation d'images dans Excel 2016

Signaler
Messages postés
534
Date d'inscription
mardi 5 août 2008
Statut
Membre
Dernière intervention
14 août 2020
-
Messages postés
6876
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 août 2020
-
Bonsoir à tous,

Tout d’abord je vous prie d’accepter tous mes meilleurs vœux pour vous et tous ceux qui vous sont chers.
Pour les besoins d’un classeur j’ai besoin d’une macro qui va copier des photos dans une cellule donnée d’une feuille Excel. Je suis W10 et Excel 2016.
J’ai trouvé une macro qui, sur le principe, devrait correspondre à ce que je cherche, malheureusement j’ai un message d’erreur suivant :
Erreur d’exécution 1004
Impossible de lire la propriété Insert de la classe Pictures


L'erreur se produite sur la ligne qui est en gras :
Sub SelectCol()
Range("C:C").Select
Call AffImage
End Sub
Sub AffImage()
' Sélectionner les cellules contenant un lien vers une image et appeler la macro
' AffImage les affichera sur le lien ou dans la colonne de gauche ou de droite
Const hDefaut = 60 ' hauteur des images
Const imgDefaut = "S:\French Digital Tour\__FDT_2019\Recup_photos_FDT2019\Couleur\BHALFA002311_11.JPG.jpg" ' saisir chemin complet et le nom de l'image par défaut à afficher si erreur
Dim msg As String, r As Long, h As Long, lmax As Long
Dim c As Range, numfich As Integer
Dim fich
msg = "Oui : Afficher les images à gauche des liens sélectionnés" & vbCrLf
msg = msg & "Non : Afficher les images sur les liens sélectionnés" & vbCrLf
msg = msg & "Annuler : Afficher les images à droite des liens sélectionnés"
r = MsgBox(msg, vbYesNoCancel, "Cellules où mettre les images")
If r = vbYes Then
r = -1
ElseIf r = vbNo Then
r = 0
Else
r = 1
End If
h = InputBox("Hauteur des lignes :", "Choix hauteur", hDefaut)
For Each c In Selection
'c.ColumnWidth = 10
fich = c.Value
' test fichier
If fich <> "" Then
If Left(fich, 7) = "http://" Then
' on conserve le lien sur le net
Else
numfich = FreeFile()
On Error GoTo errfich
Open fich For Input As #numfich
Close #numfich
On Error GoTo 0
End If
End If
'
If fich <> "" Then
c.RowHeight = h 'fixer la hauteur de ligne
ActiveSheet.Pictures.Insert(fich).Select 'ouverture image
With Selection.ShapeRange
.LockAspectRatio = msoTrue 'conserver les proportions
.Height = h - 4 'hauteur de l'image = hauteur des lignes - 4
.Left = c.Offset(0, r).Left + 2 'à gauche colonne A (sinon tu calcules avec la largeur de colonne)
.Top = c.Top + 2 'et positionner verticalement
End With
End If
Next c
Exit Sub
errfich:
fich = imgDefaut
Resume Next
End Sub


Le vous mets un lien vers ce fichier :
https://www.cjoint.com/c/JAlqdn236pn

Pouvez-vous m'aider.
Merci d’avance pour votre aide.
Mistral

3 réponses

Messages postés
6876
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 août 2020
538
Messages postés
534
Date d'inscription
mardi 5 août 2008
Statut
Membre
Dernière intervention
14 août 2020
3
Bonsoir Pivert,

Je regarde ça et je te tiens au courant mais il va d'abord falloir que je traduise cela car je ne maitrise pas du tout l'anglais.

A très vite.
Mistral
Messages postés
6876
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 août 2020
538
Comme cela:

Dim myDocument
ActiveSheet.Pictures.Insert (fich) 'ouverture image
Set myDocument = Worksheets(1)
With myDocument.Shapes.Range(1)
.LockAspectRatio = msoTrue 'conserver les proportions
.Height = h - 4 'hauteur de l'image = hauteur des lignes - 4
.Left = c.Offset(0, r).Left + 2 'à gauche colonne A (sinon tu calcules avec la largeur de colonne)
.Top = c.Top + 2 'et positionner verticalement
End With