XL 2010 Afficher image (réduction taille proportionnelle)

cathodique

cathodique

XLDnaute Barbatruc
Bonjour,

je reviens avec une autre problématique. J'ai bien cherché mais je pense que je suis un piètre fouineur.
Je voudrais afficher des images dans une plage définie (coloriée) ou une shapes (en K1) tout en gardant les proportionnalités.

j'ai pas trouvé l'équivalent de la propriété PictureSiseMode =1-fmPictureSizeModeStretch comme pour le contrôle Image des userforms.

J'utilise ce code mais les images ne s'adaptent pas à la plage (ou shapes que je n'ai pas mis).
VB: 
Option Explicit

Sub InsertImage()

   Dim ws As Worksheet
   Dim imagePath As String
   Dim imgLeft As Double
   Dim imgTop As Double

   Set ws = Feuil1
   imagePath = ThisWorkbook.Path & "\photos\" & [C4].Text & ".jpg"
   imgLeft = ws.[k1].Left
   imgTop = ws.[k1].Top

   ws.Shapes.AddPicture _
         Filename:=imagePath, _
         LinkToFile:=msoFalse, _
         SaveWithDocument:=msoTrue, _
         Left:=imgLeft, _
         Top:=imgTop, _
         Width:=-1, _
         Height:=-1

End Sub
je joins quelques images qui n'ont pas les mêmes dimensions.

En vous remerciant.

Bonne journée
 

Pièces jointes

  • Afficher image.zip
    605.8 KB · Affichages: 2
Solution
piga25
Re
Pour supprimer l'image existante avant :
VB: 
Sub InsertImage()

   Dim ws As Worksheet
   Dim imagePath As String
   Dim image As Picture
   Dim imageRange As Range
   Dim pic As Picture
  
'définition de la feuille et de la plage
   Set ws = Feuil1
   Set imageRange = ws.Range("K1:L7")
' Supprimez les images existantes dans la plage spécifiée
   For Each pic In ws.Pictures
        If Not Intersect(pic.TopLeftCell, imageRange) Is Nothing Or _
           Not Intersect(pic.BottomRightCell, imageRange) Is Nothing Then
            pic.Delete
        End If
    Next pic
' Chemin du fichier image
   imagePath = ThisWorkbook.Path & "\photos\" & [C4].Text & ".jpg"
' Insérez l'image dans la feuille
   Set image = ws.Pictures.Insert(imagePath)...
Trier par date Trier par votes
piga25

piga25

XLDnaute Barbatruc
Bonjour,
Peut-être comme cela:
VB: 
Sub InsertImage()

   Dim ws As Worksheet
   Dim imagePath As String
   Dim image As Picture
   Dim imageRange As Range
'définition de la feuille et de la plage
   Set ws = Feuil1
   Set imageRange = ws.Range("K1:L7")
' Chemin du fichier image
   imagePath = ThisWorkbook.Path & "\photos\" & [C4].Text & ".jpg"
' Insérez l'image dans la feuille
   Set image = ws.Pictures.Insert(imagePath)
' Ajustez les dimensions de l'image à la plage spécifiée
   With image
        .Top = imageRange.Top
        .Left = imageRange.Left
        .Width = imageRange.Width
        .Height = imageRange.Height
   End With
  
End Sub
 
Vote positif 0 Vote négatif
cathodique

cathodique

XLDnaute Barbatruc
piga25 à dit:
Bonjour,
Peut-être comme cela:
VB: 
Sub InsertImage()

   Dim ws As Worksheet
   Dim imagePath As String
   Dim image As Picture
   Dim imageRange As Range
'définition de la feuille et de la plage
   Set ws = Feuil1
   Set imageRange = ws.Range("K1:L7")
' Chemin du fichier image
   imagePath = ThisWorkbook.Path & "\photos\" & [C4].Text & ".jpg"
' Insérez l'image dans la feuille
   Set image = ws.Pictures.Insert(imagePath)
' Ajustez les dimensions de l'image à la plage spécifiée
   With image
        .Top = imageRange.Top
        .Left = imageRange.Left
        .Width = imageRange.Width
        .Height = imageRange.Height
   End With
 
End Sub
Cliquez pour agrandir...
Bonjour @piga25 ;),

Merci beaucoup. Certaines images débordent de la plage. Peut-être sont-elles un peu trop grandes.

Comment supprimer celle qui précède avant d’afficher la suivante? Les images sont l'une sur l'autre.

Bonne journée.
 
Vote positif 0 Vote négatif
piga25

piga25

XLDnaute Barbatruc
Re
Pour supprimer l'image existante avant :
VB: 
Sub InsertImage()

   Dim ws As Worksheet
   Dim imagePath As String
   Dim image As Picture
   Dim imageRange As Range
   Dim pic As Picture
  
'définition de la feuille et de la plage
   Set ws = Feuil1
   Set imageRange = ws.Range("K1:L7")
' Supprimez les images existantes dans la plage spécifiée
   For Each pic In ws.Pictures
        If Not Intersect(pic.TopLeftCell, imageRange) Is Nothing Or _
           Not Intersect(pic.BottomRightCell, imageRange) Is Nothing Then
            pic.Delete
        End If
    Next pic
' Chemin du fichier image
   imagePath = ThisWorkbook.Path & "\photos\" & [C4].Text & ".jpg"
' Insérez l'image dans la feuille
   Set image = ws.Pictures.Insert(imagePath)
' Ajustez les dimensions de l'image à la plage spécifiée
   With image
        .Top = imageRange.Top
        .Left = imageRange.Left
        .Width = imageRange.Width
        .Height = imageRange.Height
   End With
 
End Sub
 
Vote positif 0 Vote négatif
Solution
cathodique

cathodique

XLDnaute Barbatruc
piga25 à dit:
Re
Pour supprimer l'image existante avant :
VB: 
Sub InsertImage()

   Dim ws As Worksheet
   Dim imagePath As String
   Dim image As Picture
   Dim imageRange As Range
   Dim pic As Picture
 
'définition de la feuille et de la plage
   Set ws = Feuil1
   Set imageRange = ws.Range("K1:L7")
' Supprimez les images existantes dans la plage spécifiée
   For Each pic In ws.Pictures
        If Not Intersect(pic.TopLeftCell, imageRange) Is Nothing Or _
           Not Intersect(pic.BottomRightCell, imageRange) Is Nothing Then
            pic.Delete
        End If
    Next pic
' Chemin du fichier image
   imagePath = ThisWorkbook.Path & "\photos\" & [C4].Text & ".jpg"
' Insérez l'image dans la feuille
   Set image = ws.Pictures.Insert(imagePath)
' Ajustez les dimensions de l'image à la plage spécifiée
   With image
        .Top = imageRange.Top
        .Left = imageRange.Left
        .Width = imageRange.Width
        .Height = imageRange.Height
   End With
 
End Sub
Cliquez pour agrandir...
Pour moi bien que ça déborde pour quelques unes. Le résultat est très satisfaisant.
Je te remercie ça va me permettre d'avancer.
 
Vote positif 0 Vote négatif
piga25

piga25

XLDnaute Barbatruc
Re
Et en ajustant proportionnellement l'image en fonction de sa hauteur ou de sa largeur
VB: 
Sub InsertImage()

    Dim ws As Worksheet
    Dim imagePath As String
    Dim image As Picture
    Dim imageRange As Range
    Dim pic As Picture
    Dim aspectRatio As Double
    Dim newWidth As Double
    Dim newHeight As Double
 
'définition de la feuille et de la plage
   Set ws = Feuil1
   Set imageRange = ws.Range("K1:L7")
' Supprimez les images existantes dans la plage spécifiée
   For Each pic In ws.Pictures
        If Not Intersect(pic.TopLeftCell, imageRange) Is Nothing Or _
           Not Intersect(pic.BottomRightCell, imageRange) Is Nothing Then
            pic.Delete
        End If
    Next pic
' Chemin du fichier image
   imagePath = ThisWorkbook.Path & "\photos\" & [C4].Text & ".jpg"
' Insérez l'image dans la feuille
   Set image = ws.Pictures.Insert(imagePath)
  
' Calculer le ratio de l'image originale
   aspectRatio = image.Width / image.Height
' Ajustez les dimensions de l'image en gardant le ratio
   If imageRange.Width / imageRange.Height > aspectRatio Then
' La plage est plus large que l'image, ajuster la hauteur
        newHeight = imageRange.Height
        newWidth = newHeight * aspectRatio
    Else
' La plage est plus haute que l'image, ajuster la largeur
        newWidth = imageRange.Width
        newHeight = newWidth / aspectRatio
    End If
    ' Positionnez et redimensionnez l'image
    With image
        .Top = imageRange.Top + (imageRange.Height - newHeight) / 2
        .Left = imageRange.Left + (imageRange.Width - newWidth) / 2
        .Width = newWidth
        .Height = newHeight
    End With
 
End Sub
 
Vote positif 0 Vote négatif
piga25

piga25

XLDnaute Barbatruc
Re;
Regarde ce post, cela pourrait correspondre à ce que tu recherche:
excel-downloads.com

Microsoft 365 - Insertion Image dans une Feuille et Ratio conservé

Bonjour à tous, chère experts en VBA, je suis ultra novice. J'ai des soucis pour pour l'implantation d'image. Disons que 95% des Images de mon Document sont au format paysage et 5% au format Portrait. Jusque là pas de problème je sais lesquels sont censés être à ce format et j'ai ajusté les...
excel-downloads.com excel-downloads.com
 
Vote positif 0 Vote négatif
cathodique

cathodique

XLDnaute Barbatruc
piga25 à dit:
Re
Et en ajustant proportionnellement l'image en fonction de sa hauteur ou de sa largeur
VB: 
Sub InsertImage()

    Dim ws As Worksheet
    Dim imagePath As String
    Dim image As Picture
    Dim imageRange As Range
    Dim pic As Picture
    Dim aspectRatio As Double
    Dim newWidth As Double
    Dim newHeight As Double
 
'définition de la feuille et de la plage
   Set ws = Feuil1
   Set imageRange = ws.Range("K1:L7")
' Supprimez les images existantes dans la plage spécifiée
   For Each pic In ws.Pictures
        If Not Intersect(pic.TopLeftCell, imageRange) Is Nothing Or _
           Not Intersect(pic.BottomRightCell, imageRange) Is Nothing Then
            pic.Delete
        End If
    Next pic
' Chemin du fichier image
   imagePath = ThisWorkbook.Path & "\photos\" & [C4].Text & ".jpg"
' Insérez l'image dans la feuille
   Set image = ws.Pictures.Insert(imagePath)
 
' Calculer le ratio de l'image originale
   aspectRatio = image.Width / image.Height
' Ajustez les dimensions de l'image en gardant le ratio
   If imageRange.Width / imageRange.Height > aspectRatio Then
' La plage est plus large que l'image, ajuster la hauteur
        newHeight = imageRange.Height
        newWidth = newHeight * aspectRatio
    Else
' La plage est plus haute que l'image, ajuster la largeur
        newWidth = imageRange.Width
        newHeight = newWidth / aspectRatio
    End If
    ' Positionnez et redimensionnez l'image
    With image
        .Top = imageRange.Top + (imageRange.Height - newHeight) / 2
        .Left = imageRange.Left + (imageRange.Width - newWidth) / 2
        .Width = newWidth
        .Height = newHeight
    End With
 
End Sub
Cliquez pour agrandir...
Merci beaucoup. Avec ce dernier, ça ne va pas.
Il a supprimé le bouton qui lançait la macro mais n'a pas supprimé l'image et a planté sur cette ligne
VB: 
Set image = ws.Pictures.Insert(imagePath)

à la seconde exécution, le code a fonctionnait. Merci pour le lien, je vais aller voir.
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
Bonsoir
autant donner le lien original
excel-downloads.com

centrer une image dans un range en toute circonstances quel que soit le ratio (range/image)

bonjour a tous voici deux méthode avec exemple pour centrer une image sur un range la méthode que j'appelle directe en effet j'agit directement sur l'image en bloquant l'apect ratio...
excel-downloads.com excel-downloads.com
les images seront réduites ou "agrandies de f"acon "a ce qu'elle rentre totalement d"ans la plage sans perdre l'aspect ratio
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Question
Microsoft 365 Changement de fonctionnement d'une macro suite au passage à windows 10
Réponses
1
Affichages
353
francha62
F
Jouxte
  • Question
XL 2021 coller une image interne au classeur
2 3
Réponses
33
Affichages
834
Jouxte
Jouxte
L
  • Question
Microsoft 365 Macro Insertion image dans cellule
Réponses
3
Affichages
528
Dranreb
Dranreb
D
  • Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
545
crocrocro
C
M
  • Question
XL 2010 Insérer image dans une zone de texte
2
Réponses
15
Affichages
1 K
patricktoulon
patricktoulon
M
  • Question
XL 2010 Insérer 3 images
Réponses
11
Affichages
626
madoupa
M
C
  • Résolu(e)
XL 2013 afficher image dans Userform via HyperText
Réponses
5
Affichages
706
Cyril-neo
C
A
  • Question
XL 2019 Problème de décallage d'images à l'importation
Réponses
2
Affichages
914
Airpege
A
W
  • Résolu(e)
Microsoft 365 Insertion Image dans une Feuille et Ratio conservé
2
Réponses
23
Affichages
3 K
patricktoulon
patricktoulon
F
  • Question
Microsoft 365 Redimensionnement image
Réponses
2
Affichages
947
patricktoulon
patricktoulon

Membres actuellement en ligne

16 membres et 116 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
313 866
Messages
2 103 087
Membres
108 521
dernier inscrit
manouba