Trouver la résolution d'une photo VBA Résolu

Question

Bonjour, 

je viens solliciter l'aide du forum pour une macro VBa pour Excel.
mon problème:
-Je souhaite connaitre les propriétés des images d'un dossier pour les insérer dans un commentaire d'une cellule.
Je sais importer l'image, créer le commentaire.
Ce que je n'arrive pas à faire c'est la propriété "Exif" pour la hauteur et la largueur du JPEG (ou la résolution ), (je ne veut pas avoir à passer par le WIA puisque je dois pouvoir exécuter mon code depuis d'autre ordinateurs).

Voici un extrait de mon code:
Sub test_rezize_image()
Dim image, numero, ligne, projet As Variant
'Application.ScreenUpdating = False
projet = Left(ActiveWorkbook.Name, 3)
'On Error Resume Next
ligne = Range("C6").End(xlDown).Row
    With Sheets(1).Range("D" & ligne)
        .Comment.Visible = False
        numero = Sheets(1).Range("C" & ligne).Value
        image = "\----\masse caisse\" & projet & " images\" & numero & ".JPG"
        MsgBox (FileLen(image) / 1000 & "Ko")
        '.Comment.Shape.Width = 500
        '.Comment.Shape.Height = 350
End With
'Application.ScreenUpdating = True
End Sub

Mon problème est dans les propriété .Widht et .Height , j'aimerai pouvoir utiliser les proportions originales de l'image.
le Msgbox est un exemple que j'ai trouvé pour récupérer la taille en Ko, est-ce qu'il existe la même chose pour la résolution de l'image?

D'avance merci (j'espère avoir été clair dans mon explication ...)
Configuration: win Xp Sp2

eriiic · Answer

Bonjour, avec l'objet iPicture sans doute : https://docs.microsoft.com/en-us/windows/win32/api/ocidl/nn-ocidl-ipicture?redirectedfrom=MSDN Un exemple d'utilisation fait par michel_m (de mémoire, je n'ai pas retrouvé la discussion) : Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim chemin As String Dim design As String, image As String Dim pict As IPictureDisp, rapport As Double If Not Intersect(Target, Range("A2:A" & Range("B1").End(xlDown).Row)) Is Nothing And Target.Count = 1 Then design = Target.Offset(0, 1) If design = "aucune" Then Sheets(1).Image1.Picture = LoadPicture("") Else chemin = ThisWorkbook.Path & "\" 'A ADAPTER 'prend en compte le format de la photo If Dir(chemin & design & ".png") <> "" Then image = design & ".png" If Dir(chemin & design & ".jpg") <> "" Then image = design & ".jpg" If Dir(chemin & design & ".jpeg") <> "" Then image = design & ".jpeg" If Dir(chemin & design & ".gif") <> "" Then image = design & ".gif" 'charge la photo On Error GoTo inconnu Set pict = LoadPicture(chemin & image) 'teste format image ou portrait rapport = Round((pict.Width) / 21.16, 0) / Round((pict.Height) / 21.16, 0) 'construit et remplit la forme au format 2/3 With Sheets(1).Image1 .PictureSizeMode = 3 .Picture = pict If rapport < 1 Then .Height = 360 .Width = 240 Else .Height = 240 .Width = 360 End If '.Select End With End If End If Set pict = Nothing Exit Sub inconnu: Sheets(1).Image1.Picture = LoadPicture("") MsgBox "Nom de photo inconnu", vbCritical, "galerie photo" End Sub eric Jamais tu ne répondras à un mp non sollicité... Bon, ça c'est fait.

Trouver la résolution d'une photo VBA

1 réponse

Newsletters