Discussion :

[Carabistouilleur]

Bonjour.
Comme l'intitulé de la discussion l'indique, Je souhaiterais limiter la hauteur d'images à insérer dans Excel de manière à éviter un message d'erreur
voici une partie du code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
            'Limitation de l insertion d image en fct de la hauteur de ligne Excel
            'Hauteur des lignes 409 Points
            'Chargement de l image
            Set oChargeImage = LoadPicture(sNomJPG)
            'Test hauteur image < hauteur max cellule Excel
            If oChargeImage.Height > 409 Then
                .Cells(iLigne, Description) = "IMAGE D'ORIGINE TROP HAUTE"
            Else
                'Insertion image par la méthode AddPicture, le deuxieme argument permet d'insérer l image sans lien
                'les 4eme et 5eme sont les coordonnées, ici à l origine
                'les 6eme et 7eme sont la taille, ici la taille d'origine
                Set oImage = oSheet.Shapes.AddPicture(sNomJPG, False, True, 0, 0, -1, -1)
                'LockAspectRatio=True si la forme spécifiée conserve ses proportions d'origine
                oImage.LockAspectRatio = True
                'Placement de l image
                oImage.Top = oSheet.Cells(iLigne, Description).Top
                oImage.Left = oSheet.Cells(iLigne, Description).Left
                'ajustement de la hauteur de ligne et largeur colonne en fonction des images
                .Rows(iLigne).RowHeight = oImage.Height
                If oImage.Width > lLargeurColonne Then
                    lLargeurColonne = oImage.Width
                    .Columns(Description).ColumnWidth = lLargeurColonne * (54.29 / 288)
                End If
            End If

C'est la ligne 6 qui pose problème, en effet la plupart de mes images excèdent La hauteur limite d'une ligne Excel (409 points), Je pense qu'il y a un facteur de conversion à appliquer.
Notez que lorsqu'on fait appel à la propriété Height de l'image déjà insérée on obtient une valeur du même ordre de grandeur que les lignes Excel.

Pour préciser voici la déclaration des Variables objets:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Dim oImage                  As Shape
Dim oChargeImage            As IPictureDisp

Le problème est lié à la mesure de la hauteur de l'image à partir de l'objet de type IPictureDisp

J'apprécierais toute aide.
Merci.
Cordialement

[laurent_ott]

Bonjour,
Le plus simple, à mon avis, serait d'importer l'image puis de la supprimer si la taille ne convient pas.
Mais pour répondre à votre question :
Vous souhaitez travailler avec une image d'une hauteur de 409 points au maximum, soit 409/Application.CentimetersToPoints(1) = 14,43 cm.
Et vous utilisez LoadPicture(sNomJPG) pour contraire la taille de votre image source. Or cette fonction renvoie une taille dans une unité différente du point (je n'ai pas trouvé la référence de cette unité).
D'où la nécessité de convertir la taille de l'image source en points.
Je vous propose d'obtenir la taille de l'image source en pixel avec ce code :

Code VBA :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Dim Img As Object, Hauteur As Long
' Création d'un objet image:
Set Img = CreateObject("WIA.ImageFile")
' Chargement de l'image:
Img.LoadFile sNomJPG
' Récupération de sa hauteur en Pixels:
Hauteur = Img.Height

Sachant que l'on peut connaitre la taille en pixels de 409 points avec cette fonction : ActiveWindow.PointsToScreenPixelsY(409)
Soit 683 pixels avec un zoom à 100%.

Vous pouvez ainsi afficher votre message d'erreur si la hauteur en pixels et supérieure à votre limite :

Code VBA :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
If Hauteur > ActiveWindow.PointsToScreenPixelsY(409) Then
    MsgBox "IMAGE D'ORIGINE TROP HAUTE"
End If

Et continuer dans l'autre cas sans changer le code actuel.

Astuce - un code pour convertir les pixels en points :

Code VBA :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Function PixelEnPoint(Pixel As Long) As Long
While ActiveWindow.PointsToScreenPixelsY(PixelEnPoint) < Pixel
    PixelEnPoint = PixelEnPoint + 1
Wend
End Function

Bonne continuation.

[patmeziere]

Bonjour
en plus de la suggestion d'utiliser la librairie WIA pour chopper les dimensions en pixel
puis les convertir en point

je pense que le calcul des rowHeight et columnWidth peut se faire avec les données accessibles par vba

la propriété columnWidth donne la dimension en nombre de caractère +la marge gauche
et je supose que rowHeight donne la dimension en terme de hauteur de caractère
les propriété width et height (en lecture lecture seulement) donnent les dimensions du même nom en point

donc je remplacerais ceci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
 'ajustement de la hauteur de ligne et largeur colonne en fonction des images
                .Rows(iLigne).RowHeight = oImage.Height ' faux on est pas dans la même unité de mesure 
                If oImage.Width > lLargeurColonne Then
                    lLargeurColonne = oImage.Width
                    .Columns(Description).ColumnWidth = lLargeurColonne * (54.29 / 288) 'ça  va fonctionner peut être sur ton pc mais pas un autre  en fonction des ecrans 
                End If

par cela

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
 Dim DivoRow As Double, DiviCol As Double
 
    divirow = oImage.Height / .Rows(iLigne).RowHeight
    DiviCol = oImage.Width / .Columns(Description).ColumnWidth
 
    .Rows(iLigne).RowHeight = .Rows(iLigne).RowHeight * divirow
 
    If oImage.Width > lLargeurColonne Then
 
        'lLargeurColonne = oImage.Width'plus besoins
 
        .Columns(Description).ColumnWidth = .Columns(Description).ColumnWidth * DiviCol
    End If
'peu têtre faudra il ajouter un calcul pour le margin automatique dans les cellules (qui visiblement n'est pas accessible par VBA)

pour la fonction pointToPixel j'utilise l'arrondi de la capture en pixel d'un nombre avec PoinToScreenPixelsx - le (0) et / par ce même nombre en passant par la panes(1) de l'activewindow
comme ceci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Function PixelToPoint() As Double
    'patricktoulon (collection fonctions avec PointsToScreenPixels)
    Dim Z As Double
    With ActiveWindow.Panes(1)
        Z = .Parent.Zoom / 100
        PixelToPoint = Round(1 / ((.PointsToScreenPixelsX(7200 / Z) - .PointsToScreenPixelsX(0)) / 7200), 2)
    End With
End Function
 
'pour tester la fonction
Sub test2()
    Dim MsG As String
    MsG = "le coeff applicable sur ce pc est : " & PixelToPoint & vbCr
    MsG = MsG & "10 pixels donnent : " & 10 * PixelToPoint & " en points" & vbCr
    MsG = MsG & "1 point donne : " & 1 / PixelToPoint & " en pixel" & vbCr
    MsgBox MsG
End Sub

patrick

[Carabistouilleur]

Merci laurent_ott et patmeziere pour ces informations précieuses et que j'ai pu appliquer.
A bientôt (certainement vu mon énorme marge de progression en vba )
Cordialement.