Importation d'images dans Excel 2016

Fermé
Mistral_13200 Messages postés 634 Date d'inscription mardi 5 août 2008 Statut Membre Dernière intervention 21 mars 2024 - 11 janv. 2020 à 17:12
cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 - 12 janv. 2020 à 19:54
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
A voir également:

3 réponses

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
12 janv. 2020 à 08:04
0
Mistral_13200 Messages postés 634 Date d'inscription mardi 5 août 2008 Statut Membre Dernière intervention 21 mars 2024 4
12 janv. 2020 à 18:55
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
0
cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
12 janv. 2020 à 19:54
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

0