XL 2021 Orientation d'une image dans le commentaire d'une cellule

jeff1494 · 21 Juin 2024

Bonjour à toutes et tous;
Je rencontre le problème suivant :
J'ai un fichier Excel avec un tableau contenant 8 colonnes, et dans la deuxième colonne j'ai la description d'un objet, le but est d'insérer la photo de l'objet dans le commentaire de la cellule. Les photos sont préfixées avec la constante "OBJ" et est suivi d'un numéro d'ordre séquentiel.

J'ai une macro que j'ai récupéré qui a pour but d'insérer une image de l'objet dans le commentaire de la cellule où on est positionné. Cette image est au format "jpg", et soit avec une orientation "portrait" ou "paysage" suivant le cas.
La macro fonctionne parfaitement bien, dans le sens que je sélectionne la photo voulue depuis un dossier qui se trouve dans le même répertoire que le fichier Excel, et qu'elle est insérée dans de le commentaire de la cellule sélectionnée.

Mon problème est que l'orientation d'origine de la photo n'est pas respectée. Ce qu'elle que soit la macro utilisée (Individuelle, ou en "masse").
Pour appeler les macros je passe par le menu du ruban "Outil de saisie" juste après l'Accueil.
J'ai deux macros une pour un ajout individuel de photo (AjoutImage), et l'autre pour un ajout en "masse" de photos (AjoutLotImages).
Le résultat est le même quelle que soit la macro utilisée.
En résolvant le problème sur la première macro je pourrait ensuite régler le problème sur la deuxième.

Par exemple la première photo est en format "portrait" mais elle se retrouve en format "Paysage" dans le commentaire.
En fait toutes les images semblent faire un quart de tour vers la droite (sens horaire).
Voici la macro pour un ajout individuel de photo que j'utilise :

VB:

'Callback for BtnAddImage onAction
Sub AjoutImage(control As IRibbonControl)

    'X1c_131 Ajouter une image dans un comentaire de cellule (XLOneClick G.CHARRAULT)
    Dim PicturePath As String       'Chemin c'acces au fichier. Récupéré avec GetOpenFilename
    Dim MaxWidth As Integer
    Dim MaxHeight As Integer
    Dim pic As Object
    MaxWidth = 450
    MaxHeight = 350
  
    ' Ci après on va demander à l'utilisateur de choisir un fichier 'GetOpenFilename'
    PicturePath = Application.GetOpenFilename("images(*.jpg;*.bmp;*.png;*.gif), *.jpg;*.bmp;*.png;*.gif", , "Sélectionner une image")
    'cas ou l'utilisateur annule sa recherche
    On Error Resume Next
    'on définit une image pour en déduire les dimensions
    Set pic = ActiveSheet.Pictures.Insert(PicturePath)
    If Err.Number <> 0 Then GoTo GestError
    With ActiveCell
        'Si il n'y a pas de commentaire, on en crée un vide
        If (.Comment Is Nothing) Then .AddComment (" ")
        .Comment.Shape.Fill.UserPicture (PicturePath)
        'Déverrouillage du ratio
        .Comment.Shape.LockAspectRatio = msoFalse
        '(re-)dimensionement
        If Round(pic.Height, 0) < MaxHeight And Round(pic.Width, 0) < MaxWidth Then
            .Comment.Shape.Width = Round(pic.Width, 0)
            .Comment.Shape.Height = Round(pic.Height, 0)
        Else
            If pic.Width > pic.Height Then
                .Comment.Shape.Width = MaxWidth
                .Comment.Shape.Height = Round(pic.Height * .Comment.Shape.Width / pic.Width, 0)
            Else
                ActiveCell.Comment.Shape.Height = MaxHeight
                ActiveCell.Comment.Shape.Width = Round(pic.Width * .Comment.Shape.Height / pic.Height, 0)
            End If
        End If
        'verrouillage
        .Comment.Shape.LockAspectRatio = msoTrue
    End With
    pic.Delete
GestError:
    Set pic = Nothing
End Sub

Je subodore que mon problème est lié à la taille de l’image, mais je n'en suis pas sûr. J'ai un peu de mal à suivre tous les détails.
Cela se passerait-il dans la partie "(re-)dimensionnement"?
Donc si une personne qui serait prête à m'aider pouvait m'expliquer ce qui ne va pas j'en serais ravi.

A toutes fins utiles je vous joins un fichier ZIP qui contient les images (dossier "Jpg") ainsi que mon fichier Excel.
Aucune donnée n'est ni sensible, ni confidentielle.

D'avance je remercie chaleureusement toute personne qui m'aidera.

Bonne journée à toutes et tous.

TooFatBoy · 23 Juin 2024

jeff1494 à dit:
Alors en reprenant les conseils de TooFatBoy, et après avoir réinstallé la visionneuse de Windows, je reprends chaque photo dont l'orientation ne convient pas

Je n'ai jamais parlé d'installer, ni même d'utiliser, la Visionneuse de Windows.
J'ai parlé de l'outil de Windows permettant l'affichage des images par double-clic, que j'ai appelé "visionneuse", mais que j'aurais pu appeler "visionneur", "afficheuse", "afficheur", "visualiseuse", etc.

Pas besoin d'installer la Visonneuse de Windows des anciens Windows car, comme je l'ai dit plus haut, il suffit de sélectionner les images et de cliquer sur un bouton du ruban de l'explorateur de fichiers pour faire pivoter lesdites images.

(je précise, au cas où l'Explorateur de fichiers de Windows ait changé de nom et avant que Staple sème le doute , que je parle du truc qui permet d'afficher la liste des fichiers et leurs arborescences)

Sur ce, bon dimanche à tous

AtTheOne · 23 Juin 2024

Bonjour à toutes et à tous
En incluant dans tes deux callbacks le code lié à l'orientation de l'image donné au post #7
Tes commentaires (avec choix de l'image ou en masse) s'affichent avec la bonne orientation.
Comme j'ai fait de l'Early Binding penser à activer les références encadrées :

Code image par image:

VB:

'Callback for BtnAddImage onAction
Sub AjoutImage(control As IRibbonControl)

    'X1c_131 Ajouter une image dans un comentaire de cellule (XLOneClick G.CHARRAULT)
    Dim PicturePath      'Chemin c'acces au fichier. Récupéré avec GetOpenFilename
    Dim MaxWidth As Integer
    Dim MaxHeight As Integer
    Dim pic As Object

'================================================================================
'Ajout AtTheOne :
'================================================================================
     Dim FSO As New FileSystemObject
     Dim Img As New WIA.ImageFile, IP As New WIA.ImageProcess
     Dim Ps As WIA.Properties, P As WIA.Property
'================================================================================
'================================================================================
    
    MaxWidth = 450
    MaxHeight = 350
    
    ' Ci après on va demander à l'utilisateur de choisir un fichier 'GetOpenFilename'
    PicturePath = Application.GetOpenFilename("images(*.jpg;*.bmp;*.png;*.gif), *.jpg;*.bmp;*.png;*.gif", , "Sélectionner une image")
    'cas ou l'utilisateur annule sa recherche

'================================================================================
'Ajout AtTheOne :
'================================================================================
    
     If PicturePath = False Then Exit Sub
     FiNom = FSO.GetFileName(PicturePath)
     FiRép = FSO.GetParentFolderName(PicturePath) & "\"
    
     Img.LoadFile PicturePath
     Set Ps = Img.Properties

'Orientation de la photo (pour obtenir une orientation correcte de la miniature)
     If Ps.Exists("Orientation") Then
          Select Case Ps("Orientation").Value
               Case 1
                    RotationAngle = 0
                    FlipHorizontal = False
               Case 2
                    RotationAngle = 0
                    FlipHorizontal = True
               Case 3
                    RotationAngle = 180
                    FlipHorizontal = False
               Case 4
                    RotationAngle = 180
                    FlipHorizontal = True
               Case 5
                    RotationAngle = 90
                    FlipHorizontal = False
               Case 6
                    RotationAngle = 90
                    FlipHorizontal = False
               Case 7
                    RotationAngle = 270
                    FlipHorizontal = True
               Case 8
                    RotationAngle = 270
                    FlipHorizontal = False
          End Select
     End If
'Correction de l'Orientation
     IP.Filters.Add IP.FilterInfos("RotateFlip").FilterID
     IP.Filters(1).Properties("RotationAngle") = RotationAngle
     IP.Filters(1).Properties("FlipHorizontal") = FlipHorizontal
'Application des transformations via les filtres
     Set Img = IP.Apply(Img)

'Enregistrement temporaire du fichier (le temps d'importer la la photo)
     CheminTmp = "C:\tmp_img\"
     On Error Resume Next
     MkDir CheminTmp
     PicturePath = CheminTmp & "Thumb" & FiNom
     Kill PicturePath
     On Error GoTo 0
     Img.SaveFile PicturePath
'================================================================================
'================================================================================
    
    'on définit une image pour en déduire les dimensions
    Set pic = ActiveSheet.Pictures.Insert(PicturePath)
    
    With ActiveCell
        'Si il n'y a pas de commentaire, on en crée un vide
        If (.Comment Is Nothing) Then .AddComment (" ")
        .Comment.Shape.Fill.UserPicture (PicturePath)
'================================================================================
'Ajout AtTheOne :
'================================================================================
       'On supprime le fichier temporaire
        Kill PicturePath
'================================================================================
'================================================================================
        
        'Déverrouillage du ratio
        .Comment.Shape.LockAspectRatio = msoFalse
        '(re-)dimensionement
        If Round(pic.Height, 0) < MaxHeight And Round(pic.Width, 0) < MaxWidth Then
            .Comment.Shape.Width = Round(pic.Width, 0)
            .Comment.Shape.Height = Round(pic.Height, 0)
        Else
            If pic.Width > pic.Height Then
                .Comment.Shape.Width = MaxWidth
                .Comment.Shape.Height = Round(pic.Height * .Comment.Shape.Width / pic.Width, 0)
            Else
                ActiveCell.Comment.Shape.Height = MaxHeight
                ActiveCell.Comment.Shape.Width = Round(pic.Width * .Comment.Shape.Height / pic.Height, 0)
            End If
        End If
        'verrouillage
        .Comment.Shape.LockAspectRatio = msoTrue
    End With
    pic.Delete
GestError:
    Set pic = Nothing
End Sub

Code par lot :

VB:

Function AddCoverInCell(ff$, wst As Worksheet, r%, c%)
'================================================================================
'Ajout AtTheOne :
'================================================================================
     Dim FSO As New FileSystemObject
     Dim Img As New WIA.ImageFile, IP As New WIA.ImageProcess
     Dim Ps As WIA.Properties, P As WIA.Property
'================================================================================
    
    Dim MaxWidth As Integer
    Dim MaxHeight As Integer
    Dim pic As Object
    MaxWidth = 350
    MaxHeight = 450
'================================================================================
'Ajout AtTheOne :
'================================================================================
    
     FiNom = FSO.GetFileName(ff)
     FiRép = FSO.GetParentFolderName(ff) & "\"
    
     Img.LoadFile ff
     Set Ps = Img.Properties

'Orientation de la photo (pour obtenir une orientation correcte de la miniature)
     If Ps.Exists("Orientation") Then
          Select Case Ps("Orientation").Value
               Case 1
                    RotationAngle = 0
                    FlipHorizontal = False
               Case 2
                    RotationAngle = 0
                    FlipHorizontal = True
               Case 3
                    RotationAngle = 180
                    FlipHorizontal = False
               Case 4
                    RotationAngle = 180
                    FlipHorizontal = True
               Case 5
                    RotationAngle = 90
                    FlipHorizontal = False
               Case 6
                    RotationAngle = 90
                    FlipHorizontal = False
               Case 7
                    RotationAngle = 270
                    FlipHorizontal = True
               Case 8
                    RotationAngle = 270
                    FlipHorizontal = False
          End Select
     End If
'Correction de l'Orientation
     IP.Filters.Add IP.FilterInfos("RotateFlip").FilterID
     IP.Filters(1).Properties("RotationAngle") = RotationAngle
     IP.Filters(1).Properties("FlipHorizontal") = FlipHorizontal
'Application des transformations via les filtres
     Set Img = IP.Apply(Img)

'Enregistrement temporaire du fichier (le temps d'importer la la photo)
     CheminTmp = "C:\tmp_img\"
     On Error Resume Next
     MkDir CheminTmp
     ff = CheminTmp & "Thumb" & FiNom
     Kill ff
     On Error GoTo 0
     Img.SaveFile ff
'================================================================================
    
    On Error Resume Next
    Set pic = wst.Pictures.Insert(ff)
    If Err.Number <> 0 Then GoTo GestError
    With wst.Cells(r, c)
        If (.Comment Is Nothing) Then .AddComment (" ")
        .Comment.Shape.Fill.UserPicture (ff)
'================================================================================
'Ajout AtTheOne :
'================================================================================
     Kill ff
'================================================================================
        .Comment.Shape.LockAspectRatio = msoFalse
        If Round(pic.Height, 0) < MaxHeight And Round(pic.Width, 0) < MaxWidth Then
            .Comment.Shape.Width = Round(pic.Width, 0)
            .Comment.Shape.Height = Round(pic.Height, 0)
        Else
            If pic.Width > pic.Height Then
                .Comment.Shape.Width = MaxWidth
                .Comment.Shape.Height = Round(pic.Height * .Comment.Shape.Width / pic.Width, 0)
            Else
                wst.Cells(r, c).Comment.Shape.Height = MaxHeight
                wst.Cells(r, c).Comment.Shape.Width = Round(pic.Width * .Comment.Shape.Height / pic.Height, 0)
            End If
        End If
        .Comment.Shape.LockAspectRatio = msoTrue
    End With
    pic.Delete
GestError:
    Set pic = Nothing
End Function

Voir fichier joint

job75 · 24 Juin 2024

Bonjour jeff1494, le forum,

A partir de la Shape créée par Insert on peut créer un fichier JPEG provisoire :

VB:

Sub AjoutImage(control As IRibbonControl, Optional cel As Range, Optional fichier As Variant)
    Dim pic As Object, ratio#
    If cel Is Nothing Then
        Set cel = ActiveCell
        fichier = Application.GetOpenFilename("images(*.jpg;*.bmp;*.png;*.gif), *.jpg;*.bmp;*.png;*.gif", , "Sélectionner une image")
        If fichier = False Then Exit Sub
    End If
    Application.ScreenUpdating = False
    Set pic = ActiveSheet.Pictures.Insert(fichier)
    ratio = pic.Height / pic.Width
    If pic.ShapeRange.Rotation = 90 Then ratio = 1 / ratio
    fichier = ThisWorkbook.Path & "\Image.jpg"
    pic.CopyPicture
    With ActiveSheet.ChartObjects.Add(0, 0, 300, ratio * 300).Chart
        Do
            .Paste 'Coller
            DoEvents
        Loop While .Shapes.Count = 0 'en attente du collage
        .Export fichier, "JPG" 'création du fichier JPEG
        .Parent.Delete
    End With
    pic.Delete
    With cel
        .ClearComments 'RAZ
        .AddComment ""
        .Comment.Shape.Width = 300 'à adapter
        .Comment.Shape.Height = ratio * .Comment.Shape.Width
        .Comment.Shape.Fill.UserPicture fichier
    End With
    Kill fichier
End Sub

Sub AjoutLotImages(control As IRibbonControl)
Dim chemin$, fichier$, n&
chemin = ThisWorkbook.Path & "\Jpg\"
fichier = Dir(chemin & "*.jpg")
While fichier <> ""
    n = n + 1
    AjoutImage Nothing, Sheets("Liste").Cells(n + 1, 2), chemin & fichier
    fichier = Dir
Wend
End Sub

Je note que toutes les images du dossier Jpg ont une rotation de 90°.

A+

job75 · 24 Juin 2024

Pour tester j'ai mis un compteur dans la boucle Do/Loop.

Chez moi il faut 3 ou 4 boucles pour que le collage se fasse.

jeff1494 · 24 Juin 2024

Bonjour toutes et tous;

Merci à @job75 et @AtTheOne pour votre aide, et vos suggestions.

@AtTheOne : Je vais décortiquer ton code et essayer de le comprendre. C'est pas forcément gagné d'avance, mais j'y arriverai. En tous cas merci d'avoir pris le temps d'intégrer ton code dans mes macros. Ce sera plus facile pour moi à comprendre.

@job75 : Même remarque que pour AtTheOne. Il me faut maintenant comparer mes macros avec celles que tu as modifié pour pouvoir les comprendre.

Dans tous les cas je voudrais vous remercier chaleureusement pour votre temps passé avec mon problème, ainsi que pour votre aide à le résoudre. Maintenant à moi de jouer. Je dois d'abord comprendre puis mettre en place.

Une fois que cela sera fait je vous tiendrais au courant. Malheureusement ce ne sera pas dans l'immédiat car mon épouse traverse une période un peu difficile, et je m'occupe plus d'elle que de mon problème Excel.

Encore un grand merci à tous pour votre soutien et votre aide.
Bonne soirée à vous.

TooFatBoy · 24 Juin 2024

jeff1494 à dit:
Une fois que cela sera fait je vous tiendrais au courant. Malheureusement ce ne sera pas dans l'immédiat car mon épouse traverse une période un peu difficile, et je m'occupe plus d'elle que de mon problème Excel.

Vu que tu n'as pas trop de temps à consacrer à Excel et puisque tu modifies tes photographies pour en diminuer le poids (et la taille apparemment), ne t'embête pas à essayer de comprendre des macros qui n'auront besoin d'agir qu'une seule fois, mais utilise plutôt un soft qui te fait tout en une seule fois et sur toutes les images désirées en même temps.

Bon courage à toi et surtout à Madame !

jeff1494 · 25 Juin 2024

Merci TooFatBoy.
En effet tu as raison dans le sens que ces macros ne serviront pas souvent. Mais c'est pour moi l'occasion d'apprendre. Et apprendre n'a jamais fait de mal à personne.
Merci pour ton empathie.
Je te souhaite une bonne journée.

job75 · 25 Juin 2024

Bonjour jeff1494, TooFatBoy, le forum,

TooFatBoy à dit:
ne t'embête pas à essayer de comprendre des macros qui n'auront besoin d'agir qu'une seule fois

Si c'est bien le cas il est également inutile d'utiliser un fichier avec un ruban personnalisé.

Utilisez alors le fichier zippé joint et ce code :

VB:

Dim cel As Range, fichier As Variant 'mémorise les variables

Sub AjoutImageUnique()
    Dim pic As Object, ratio#
    If cel Is Nothing Then
        Set cel = ActiveCell
        fichier = Application.GetOpenFilename("images(*.jpg;*.bmp;*.png;*.gif), *.jpg;*.bmp;*.png;*.gif", , "Sélectionner une image")
        If fichier = False Then Exit Sub
    End If
    Application.ScreenUpdating = False
    Set pic = ActiveSheet.Pictures.Insert(fichier)
    ratio = pic.Height / pic.Width
    If pic.ShapeRange.Rotation = 90 Then ratio = 1 / ratio
    fichier = ThisWorkbook.Path & "\Image.jpg"
    pic.CopyPicture
    With ActiveSheet.ChartObjects.Add(0, 0, 300, ratio * 300).Chart
        Do
            .Paste 'Coller
            DoEvents
        Loop While .Shapes.Count = 0 'en attente du collage
        .Export fichier, "JPG" 'création du fichier JPEG
        .Parent.Delete
    End With
    pic.Delete
    With cel
        .ClearComments 'RAZ
        .AddComment ""
        .Comment.Shape.Width = 300 'à adapter
        .Comment.Shape.Height = ratio * .Comment.Shape.Width
        .Comment.Shape.Fill.UserPicture fichier
    End With
    Kill fichier
    Set cel = Nothing
    fichier = Empty
End Sub

Sub AjoutImagesLot()
Dim chemin$, fich$, n&
chemin = ThisWorkbook.Path & "\Jpg\"
fich = Dir(chemin & "*.jpg")
While fich <> ""
    n = n + 1
    Set cel = Sheets("Liste").Cells(n + 1, 2)
    fichier = chemin & fich
    AjoutImageUnique
    fich = Dir
Wend
End Sub

A+

TooFatBoy · 25 Juin 2024

job75 à dit:
Si c'est bien le cas il est également inutile d'utiliser un fichier avec un ruban personnalisé.

Ah oui, c'est pas faux. Bien vu.

Du coup ce que j'ai dit est encore plus vrai : faudrait être un peu stupide pour s'embêter à utiliser une macro qui va retourner l'image à chaque fois qu'elle est intégrée dans un commentaire alors qu'il suffit d'utiliser des fichiers déjà dans le bon sens.

patricktoulon · 25 Juin 2024

Bonjour à tous

juste en passant et de mon point de vu
à choisir
méthode 1 @jurassic pork (avec wia)
méthode 2 @job75 (export par graph)

je choisi sans hésiter la solution de @jurassic pork

raisons:
1 c'est certainement plus rapide qu'un insertpicture/copypicture paste in the chart and export

2 la qualité de l'image (et c'est incontestable ,je n'ai aucun doute sur la question) sera plus importante avec WIA

3 on a souvent même en enlevant le line du chart et de la picture on garde souvent des bordures(voir une bordure sur le bottom et right de l'image )

4 et pas des moindres il a prévu dans sa macro d'autre dégrée de rotation

je dis ça moi je dis rien

AtTheOne · 25 Juin 2024

Bonjour à toutes & à tous, @patricktoulon , @job75, @TooFatBoy, @jurassic pork, @jeff1494 ...
Comme tout le monde défend son bout de gras je m'y mets aussi.
Ce que j'ai proposé au post 7 et intégré dans les callbacks de @jeff1494 au post 32 fonctionne quelque soit l'orientation de l'image.
Méthode avec WIA comme @jurassic pork, améliorable sans doute mais qui fonctionne.
C'est vous qui voyez ...

patricktoulon · 25 Juin 2024

Bonjour @AtTheOne
à proprement parler ton fichier ne répond pas à la demande
certes tu nous fait une belle démonstration de l'utilisation des properties avec WIa
je verrais plutôt ton fichier comme le préambule d'une mini app pour image

AtTheOne · 25 Juin 2024

patricktoulon à dit:
Bonjour @AtTheOne
à proprement parler ton fichier ne répond pas à la demande
certes tu nous fait une belle démonstration de l'utilisation des properties avec WIa
je verrais plutôt ton fichier comme le préambule d'une mini app pour image

Bonjour @patricktoulon,
euh quand même, le post 32 comporte les 2 callbacks de @jeff1494 avec le traitement de l'image par WIA de l'orientation de l'image comme demandé au tout début.
Vu le niveau affiché (personnalisation du ruban) dans un premier temps je pensais que Jeff pouvais intégrer le traitement de l'orientation dans ses macros.
Dans un deuxième temps, j'ai intégré le strict nécessaire dans ses macros ...
Mais bon ce n'est pas très grave
A bientôt

XL 2021 Orientation d'une image dans le commentaire d'une cellule

jeff1494

XLDnaute Occasionnel

Pièces jointes

TooFatBoy

XLDnaute Barbatruc

AtTheOne

XLDnaute Accro

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

jeff1494

XLDnaute Occasionnel

TooFatBoy

XLDnaute Barbatruc

jeff1494

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

TooFatBoy

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

AtTheOne

XLDnaute Accro

patricktoulon

XLDnaute Barbatruc

AtTheOne

XLDnaute Accro

Discussions similaires