Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Microsoft 365 Macro insertion image dans Excel

Amelie2j

XLDnaute Nouveau
Bonjour,

Petit sujet certainement déjà traité mais je n'arrive pas à m'en sortir.
J'utilise la macro ci-dessous pour insérer des images sur excel et cela marche à merveille.
néanmoins, comment faire pour que les images restent dans le fichier si je l'envoi à un client?
Comment rompre les liaisons ?

Merciiii

Sub SelectCol()
Range("A:A").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 = 75 ' hauteur des images
Const imgDefaut = "" ' 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
 

Discussions similaires

Réponses
5
Affichages
185
Réponses
1
Affichages
168
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…