Détecter la taille des photos à insérer

Bonjour à Toutes et à Tous,

J'utilise une macro, qui fonctionne très bien, qui insére des photos dans les cellules et les dimensionnent à la taille des cellules.

Ma question est : peux t'on filtrer lors de cette insertion des photos qui ont une taille trop élevées, exemple : au dessus de 300Ko, l'insertion de la photo n'est pas possible.

J'ai un fichier qui commence à prendre du volume (4 giga) et j'aimerai forcer les utilisateurs à compresser les photos avant leurs insertion dans le document.

je pense qu'avec la macro insertion/dimension cellule, il y a déjà une compression mais est-ce suffisant, je n'en sais rien.

Macro utilisé pour l'insertion d'image :

Sub insere_image_ratio()
Dim ficimg As String, Ad As String
Dim MemW As Long, MemH As Long, T As Integer, L As Integer
Dim Lg As Integer, HT As Integer, RatioCell As Single
Dim CellH As Long, CellW As Long, RatioHz As Single, RatioVt As Single
    Ad = Selection.Address
    CellH = Selection.Height
    CellW = Selection.Width
    ficimg = Application.GetOpenFilename(".jpg,*.jpg,.gif,*.gif,.jpeg,*.jpeg", , "Choisissez l'image") ' choix nom du fichier
    If ficimg = "Faux" Then Exit Sub
    ActiveSheet.Pictures.Insert(ficimg).Select ' insertion
    With Selection.ShapeRange
        MemW = .Width: MemH = .Height
        'adapte les ratio
        If MemH < CellH And MemW < CellW Then
        'l'image < cellule
            RatioHz = MemH / CellH
            RatioVt = MemW / CellW
            If RatioVt < RatioHz Then 'adapter en hauteur
                HT = CellH:  Lg = MemW * (HT / MemH)
                T = 0: L = (CellW - Lg) / 2
            Else 'adapter en largeur
                Lg = CellW: HT = MemH * (CellW / MemW)
                L = 0: T = (CellH - HT) / 2
            End If
        ElseIf MemH > CellH And MemW > CellW Then
        'l'image > cellule
            RatioHz = CellH / MemH
            RatioVt = CellW / MemW
            If RatioVt > RatioHz Then 'adapter en hauteur
                HT = CellH:  Lg = MemW * (HT / MemH)
                T = 0: L = (CellW - Lg) / 2
            Else 'adapter en largeur
                Lg = CellW: HT = MemH * (Lg / MemW)
                L = 0: T = (CellH - HT) / 2
            End If
        ElseIf MemH > CellH And MemW < CellW Then
        'adapter en hauteur
            HT = CellH:  Lg = MemW * (HT / MemH)
            T = 0: L = (CellW - Lg) / 2
        ElseIf MemH < CellH And MemW > CellW Then
        'adapter en largeur
            Lg = CellW: HT = MemH * (Lg / MemW)
            L = 0: T = (CellH - HT) / 2
        Else
            Stop ' pas prévu ?
        End If

        .LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
        .Top = Range(Ad).Top + T ' haut de la cellule
        .Left = Range(Ad).Left + L ' gauche de la cellule
        .Height = HT
        .Width = Lg ' largeur des cellules fusionnées
    End With
    With Selection
        .Placement = xlMoveAndSize
        .PrintObject = True
    End With
End Sub

Merci d'avance.

Bonjour,

Après une navigation sur d'autres forum (celui-là reste tout de même de loin le mieux en qualité visuel!) j'ai trouvé un bout de code sur un autre forum pour "lire" la proprièté d'une image :

Private Sub CommandButton2_Click()

Dim Img As ImageFile
Dim P As Property
Dim S As String

    'Création conteneur pour l'image à manipuler
    Set Img = CreateObject("WIA.imageFile")

    'Chargement de l'image dans le conteneur
    Img.LoadFile ("D:\users\ngand\Documents\photos\Desert.jpg")

    'Boucle sur la collection de propriétés
    For Each P In Img.Properties
        S = P.Name & "(" & P.PropertyID & ") = "
        If P.IsVector Then
            S = S & " - vector data not emitted - "

            ElseIf P.Type = RationalImagePropertyType Then
            S = S & P.Value.Numerator & "/" & P.Value.Denominator

            ElseIf P.Type = StringImagePropertyType Then
            S = S & """" & P.Value & """"

            Else
            S = S & P.Value
        End If
        Debug.Print S
    Next

End Sub

Ca beug encore chez moi mais je vais essayer de m'appuyer dessus.

Si ça peut servir autant le partager.