Macro Excel 2010 - Insérer automatiquement des images sans déformation

Le 07/12/2018 à 11:07

Bonjour,

Je ne suis pas une pro des macros mais je dois intégrer des photos à une liste de plusieurs centaines de lignes, chaque ligne correspondant à une photo qui se trouve dans un dossier sur mon disque : la photo est là pour identifier l'objet dont on détaille les caractéristiques dans les autres colonnes.

Pour certaines lignes, la photo n'existe pas encore, mais me sera remise plus tard et il faudra que je l'intègre alors.

Voici la macro que j'ai trouvée, en piochant ici et là dans des tutos sur le web. Elle fonctionne, mais avec un bouton, et pour une seule photo sur une seule ligne. Il faudrait que la macro fasse la même chose pour toutes les lignes en une seule fois.

Par ailleurs, je ne sais pas comment indiquer que le bord droit de la photo doit être variable en fonction de la hauteur, pour qu'elle ait la même proportion que l'original et ne soit pas déformée.

Enfin, je ne sais pas comment réduire le poids en pixel de l'image originale pour que mon fichier ne soit pas trop lourd.

Private Sub cmdDisplayPhoto_Click()

Application.ScreenUpdating = False

Dim RegieNumber As String, T As String

myDir = "C:\Documents\Photos\"

RegieNumber = Range("D2")

T = ".jpg"

Range("E2").Value = RegieNumber

On Error GoTo errormessage:

ActiveSheet.Shapes.AddPicture Filename:=myDir & RegieNumber & T, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=Range("E2").Left, Top:=Range("E2").Top, Width:=60, Height:=78

errormessage:

If Err.Number = 1004 Then

MsgBox "File does not exist" & vbCrLf & "Check of the RegieNumber !"

Range("F2").Value = ""

Range("B2").Value = ""

End If

Application.ScreenUpdating = True

End Sub

Voilà, je ne sais pas si vous pouvez m'aider mais cela fait trois jours que je n'avance plus, donc un coup de main me serait bien utile.

Un grand merci d'avance !

Marie

Le 07/12/2018 à 12:38

Bonjour Marie, et bienvenue sur ce Forum !

Paennn a écrit :

Il faudrait que la macro fasse la même chose pour toutes les lignes en une seule fois.

Je suppose que tu devrais utiliser une Boucle !

Donc essaye avec le code ci-dessous :

Private Sub cmdDisplayPhoto_Click()
Dim x As Long
Application.ScreenUpdating = False
Dim RegieNumber As String, T As String
myDir = "C:\Documents\Photos\"
For x = 2 To Range("D" & Rows.Count).End(xlUp).Row
    RegieNumber = Range("D" & x)
    T = ".jpg"
    Range("E" & x).Value = RegieNumber
    On Error GoTo errormessage:
    ActiveSheet.Shapes.AddPicture Filename:=myDir & RegieNumber & T, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=Range("E" & x).Left, Top:=Range("E" & x).Top, Width:=60, Height:=78
errormessage:
    If Err.Number = 1004 Then
        MsgBox "File does not exist" & vbCrLf & "Check of the RegieNumber !"
        Range("F" & x).Value = ""
        Range("B" & x).Value = ""
    End If
Next
End Sub

Restant à ta dispo!

Le 07/12/2018 à 14:20

Merci beaucoup Juice, ça fonctionne, c'est formidable !

Le seul souci, c'est que les photos ont toutes la même largeur ce qui fait que la photo est déformée, car je ne sais pas comment écrire qu'elles doivent avoir une largeur proportionnelle à la largeur d'origine en fonction de la nouvelle hauteur.

je pense que c'est dans cette partie du code :

ActiveSheet.Shapes.AddPicture Filename:=myDir & RegieNumber & T, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=Range("E" & x).Left, Top:=Range("E" & x).Top, Width:=60, Height:=78

Au lieu de Width:=60 il faudrait mettre quelque chose mais je ne sais pas trop quoi.

Tu as une idée ?

Le 07/12/2018 à 19:21

J'ai changé comme ceci, mais ça ne marche pas non plus :

ActiveSheet.Shapes.AddPicture Filename:=myDir & RegieNumber & T, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=Range("E" & x).Left, Top:=Range("E" & x).Top, Width:=LockAspectRatio, Height:=78

Help !

Le 07/12/2018 à 23:38

Re-

Excuse moi pour mon absence de retour, mais je suis normalement inactif le week-end :p (L'week-end c'est fait pour être posay dans son canapay)

Et puis j'ai réfléchis et tenter de trouver des solutions mais c'est pas facile à résoudre ton cas.

En gros tu veux garder une image non déformer après avoir toucher à la hauteur de celle-ci; Donc que la largeur de l'image s'adapte à la nouvelle hauteur.

Ton cas dans un exemple simple :

Dans l'exemple, sa ferra donc : (150 x 100) / 200 = 75 -> Qui serait la LARGEUR idéale pour que mon Image ne paraisse pas déformée après j'ai modifié la HAUTEUR

Tout sa pour dire que si tu veux une solution à ton problème : Faut juste trouver la hauteur initiale de ton image :p

Restant à dispo! (Mais Lundi hein oh xD)

Le 10/12/2018 à 17:45

Bonsoir,

Moi non plus je ne travaille pas le week-end !

Je ne vais pas pouvoir trouver la hauteur initiale de l'image, j'en ai 500 à importer. Mais je note bien que c'est une piste, c'est forcément un bout de la solution.

Je vais donc continuer à chercher dans les tutos... Si je trouve, je te dis.

Merci encore en tous cas de ton aide ! C'est déjà formidable que j'arrive à avoir un bout de la bonne image pour chaque ligne.

Marie

Le 10/12/2018 à 18:38

Bonjour,

Si tu veux avoir un rapport hauteur/largeur, il te suffit de multiplier la hauteur initiale par le rapport de la largeur initiale sur la nouvelle largeur :

=Hauteur_Initiale x Largeur_Initiale/Nouvelle_Largeur

Exemple, une piste simple avec un code récupéré sur le net (Excel-Malin.com) et quelques modifs pour avoir les dimensions séparées dans un tableau :

H = 200 x 150 / 100 = 300

Sub test()

    Dim Tbl() As Single
    Dim R As Single
    Dim Hauteur As Integer

    Tbl = DimensionsImage(myDir & RegieNumber & T)
    If Tbl(1) = -1 Then MsgBox "Erreur sur la photo '" & myDir & RegieNumber & T & "' !": Exit Sub

    'adapter le rapport R = Tbl(2) / Tbl(1) ou R = Tbl(1) / Tbl(2)
    R = Tbl(2) / Tbl(1)

    Hauteur = 78

    ActiveSheet.Shapes.AddPicture myDir & RegieNumber & T, msoFalse, msoTrue, Range("E" & x).Left, Range("E" & x).Top, Hauteur, Hauteur * R

End Sub

Public Function DimensionsImage(Fichier As String) As Single()
    'par Excel-Malin.com ( https://excel-malin.com )

    Dim Tbl(1 To 2) As Single
    Dim T
    Dim Dimensions As String
    Dim objShell As Object
    Dim objDossier As Object
    Dim objFichier As Object

    On Error GoTo Erreur

    Dim ImageDossier As Variant
    Dim ImageFichier As Variant

    ImageFichier = Mid(Fichier, InStrRev(Fichier, "\") + 1)
    ImageDossier = Left(Fichier, Len(Fichier) - Len(ImageFichier))

    Set objShell = CreateObject("Shell.Application")

    Set objDossier = objShell.Namespace(ImageDossier)
    Set objFichier = objDossier.ParseName(ImageFichier)

    Dimensions = CStr(objFichier.ExtendedProperty("Dimensions"))
    Dimensions = Left(Dimensions, Len(Dimensions) - 1)
    Dimensions = Right(Dimensions, Len(Dimensions) - 1)

    T = Split(Dimensions, "x")

    Tbl(1) = CSng(Trim(T(0)))
    Tbl(2) = CSng(Trim(T(1)))

    DimensionsImage = Tbl()

    Set objFichier = Nothing

    Exit Function

Erreur:
    Tbl(1) = -1
    Tbl(2) = -1

    DimensionsImage = Tbl()

End Function
Le 11/12/2018 à 11:38

Bonjour à tous,

Et merci à nouveau pour votre aide, c'est génial, je ne me sens plus seule devant mon problème !

Donc j'ai fait un mix pour essayer d'intégrer les propositions de Juice et Theze, et voilà ce que cela donne, mais... cela ne marche pas ! Il doit y avoir une erreur, et certainement plusieurs, mais je suis tellement nouvelle en macro que je ne sais pas du tout où elles sont. Si vous avez des pistes...

Private Sub cmdDisplayPhoto_Click()

Dim x As Long
Application.ScreenUpdating = False
Dim RegieNumber As String, T As String
For x = 2 To Range("D" & Rows.Count).End(xlUp).Row
    RegieNumber = Range("D" & x)
    T = ".jpg"
    Range("E" & x).Value = RegieNumber

Dim Tbl() As Single
Dim R As Single
Dim Hauteur As Integer

    myDir = "C:\Documents\Photos\"

    Tbl = DimensionsImage(myDir & RegieNumber & T)
    If Tbl(1) = -1 Then MsgBox "Erreur sur la photo '" & myDir & RegieNumber & T & "' !": Exit Sub

    'adapter le rapport R = Tbl(2) / Tbl(1) ou R = Tbl(1) / Tbl(2)
    R = Tbl(2) / Tbl(1)

    Hauteur = 78

    ActiveSheet.Shapes.AddPicture myDir & RegieNumber & T, msoFalse, msoTrue, Range("E" & x).Left, Range("E" & x).Top, Hauteur, Hauteur * R

End With

Public Function DimensionsImage(Fichier As String) As Single()
    'par Excel-Malin.com ( https://excel-malin.com )

    Dim Tbl(1 To 2) As Single
    Dim T
    Dim Dimensions As String
    Dim objShell As Object
    Dim objDossier As Object
    Dim objFichier As Object

    On Error GoTo Erreur

    Dim ImageDossier As Variant
    Dim ImageFichier As Variant

    ImageFichier = Mid(Fichier, InStrRev(Fichier, "\") + 1)
    ImageDossier = Left(Fichier, Len(Fichier) - Len(ImageFichier))

    Set objShell = CreateObject("Shell.Application")

    Set objDossier = objShell.Namespace(ImageDossier)
    Set objFichier = objDossier.ParseName(ImageFichier)

    Dimensions = CStr(objFichier.ExtendedProperty("Dimensions"))
    Dimensions = Left(Dimensions, Len(Dimensions) - 1)
    Dimensions = Right(Dimensions, Len(Dimensions) - 1)

    T = Split(Dimensions, "x")

    Tbl(1) = CSng(Trim(T(0)))
    Tbl(2) = CSng(Trim(T(1)))

    DimensionsImage = Tbl()

    Set objFichier = Nothing

    Exit Function

Erreur:
    Tbl(1) = -1
    Tbl(2) = -1

    DimensionsImage = Tbl()

End Function
Le 11/12/2018 à 13:03

Re- Marie,

Salut Theze,

Bon, je suis repartie de rien pour refaire ton code, parceque je ne comprenais plus où on en était là xD

Ci-dessous le code largement testé et qui fonctionne chez moi :

Par "fonctionne" j’entends que :

  • La largeur s'ajuste automatiquement pour ne pas que l'image paraisse déformée

Je te laisse voir et revenir vers nous :p

Sub InstertImage()
Dim Hauteur As Long, Largeur As Long, NewLargeur As Long
Dim Way As String, Title As String, Ext As String
Dim Sh As Object
Dim x As Long
Way = "C:\Documents\Photos\"
Ext = ".jpg"
For x = 2 To Range("D" & Rows.Count).End(xlUp).Row
    Title = Cells(x, 4)
    Set Sh = ActiveSheet.Pictures.Insert(Way & Title & Ext)
    Hauteur = Sh.Height
    Largeur = Sh.Width
    Sh.Delete
    NewLargeur = ((78 * Largeur) / Hauteur)
    ActiveSheet.Shapes.AddPicture Filename:=Way & Title & Ext, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=Range("E" & x).Left, Top:=Range("E" & x).Top, Width:=NewLargeur, Height:=78
Next
End Sub

Restant à dispo

Le 11/12/2018 à 13:54

Bonjour,

Dans le même esprit :

Private Sub cmdDisplayPhoto_Click()

    Dim Tbl() As Single
    Dim Dossier As String
    Dim Fichier As String
    Dim Ext As String
    Dim Hauteur As Integer
    Dim Largeur As Integer
    Dim X As Long

    Dossier = "C:\Documents\Photos\"
    Ext = ".jpg"
    Hauteur = 78 'c'est la hauteur qui va définir la taille de l'image
    'Largeur = 78 si c'est la largeur qui va définir la taille de l'image

    Application.ScreenUpdating = False

    For X = 2 To Range("D" & Rows.Count).End(xlUp).Row

        Fichier = Range("D" & X)
        Range("E" & X).Value = Dossier

        Tbl = DimensionsImage(Dossier & Fichier & Ext)
        If Tbl(1) = -1 Then MsgBox "Erreur sur la photo '" & Dossier & Fichier & Ext & "' !": Exit Sub

        'Tbl(1) = largeur, Tbl(2) = hauteur
        Largeur = Tbl(1) / (Tbl(2) / Hauteur) '<--- la largeur de la photo est rammenée au même rapport que la hauteur
        'Hauteur = Tbl(2) / (Tbl(1) / Largeur) '<--- si c'est la largeur qui doit fixer la taille de l'image

        ActiveSheet.Shapes.AddPicture mydir & RegieNumber & T, msoFalse, msoTrue, Range("E" & X).Left, Range("E" & X).Top, Largeur, Hauteur

    Next X

End Sub

je ne re-poste pas la fonction qui reste inchangée !

Le 11/12/2018 à 15:36

Cher Juice,

Je suis impressionnée par ta nouvelle formule, qui marche (presque) parfaitement.

Donc les photos maintenant s'affichent bien :

  • en hauteur 78,
  • en largeur variable, ce qui fait qu'elles ne sont pas déformées,
  • automatiquement pour toutes les cellules, ce qui est le but de la manœuvre.

Sauf que le programme s'arrête dès qu'il y a une photo manquante : il affiche toutes les photos au-dessus et aucune au-dessous.

Et il indique le message suivant : "Erreur d'exécution 1004 : impossible de lire la propriété Insert de la classe Pictures"

Quand je clique sur Débogage, la ligne suivante est surlignée :

Set Sh = ActiveSheet.Pictures.Insert(Way & Title & Ext)

Je suis sûre que tu as la solution.

Merci, merci, merci mille fois encore, c'est déjà formidable.

Marie

Le 11/12/2018 à 15:38

Marie,

Ah oui j'ai zappé de te remettre ton gestionnaire d'erreur.

Je te fais sa et je reviens vers toi !

A toute ;D

Le 11/12/2018 à 15:56

Re-

Est-ce que tu veux absolument un message d'erreur si l'image n'existe pas ?

Parce que la méthode que tu a de base [...]

On Error GoTo errormessage:

errormessage:
If Err.Number = 1004 Then
MsgBox "File does not exist" & vbCrLf & "Check of the RegieNumber !"

[...] ne fonctionne pas avec mon code, alors qu'une simple ligne : On Error Resume Next permet d'extraire toute les images d'un coup.

Nouveau code avec gestion de l'erreur :

Sub InstertImage()
Dim Hauteur As Long, Largeur As Long, NewLargeur As Long
Dim Way As String, Title As String, Ext As String
Dim Sh As Object
Dim x As Long
Way = "C:\Documents\Photos\"
Ext = ".jpg"
For x = 2 To Range("D" & Rows.Count).End(xlUp).Row
    Title = Cells(x, 4)
    On Error Resume Next
    Set Sh = ActiveSheet.Pictures.Insert(Way & Title & Ext)
    Hauteur = Sh.Height
    Largeur = Sh.Width
    Sh.Delete
    NewLargeur = ((78 * Largeur) / Hauteur)
    ActiveSheet.Shapes.AddPicture Filename:=Way & Title & Ext, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=Range("E" & x).Left, Top:=Range("E" & x).Top, Width:=NewLargeur, Height:=78
Next
End Sub

Restant à ta dispo si sa conviens pas

Le 11/12/2018 à 16:32

Cher Juice,

Bon ben je crois que là on est bons.... Ça marche !!!!

Et ça marche super bien même.

Mille mercis encore à toi et à tous ceux qui ont aidé.

Vous n'imaginez pas comme ça va me rendre service ce programme !

Vous êtes super forts !

Bonne journée et peut être à bientôt,

Marie

Rechercher des sujets similaires à "macro 2010 inserer automatiquement images deformation"