Trouver la résolution d'une photo VBA

Résolu/Fermé

pou pouille Messages postés 207 Date d'inscription mardi 20 octobre 2009 Statut Membre Dernière intervention 20 juillet 2012 - 18 juil. 2012 à 15:45
pou pouille Messages postés 207 Date d'inscription mardi 20 octobre 2009 Statut Membre Dernière intervention 20 juillet 2012 - 20 juil. 2012 à 15:49

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 ...)

A voir également:

Trouver la résolution d'une photo VBA
Traduction photo gratuit - Guide
Photo de profil - Guide
Partage photo - Guide
Trouver adresse mac - Guide
Photo aérienne de ma maison - Guide

1 réponse

Réponse 1 / 1

eriiic Messages postés 24570 Date d'inscription mardi 11 septembre 2007 Statut Contributeur Dernière intervention 23 avril 2024 7 213
Modifié par eriiic le 18/07/2012 à 18:14

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.

pou pouille Messages postés 207 Date d'inscription mardi 20 octobre 2009 Statut Membre Dernière intervention 20 juillet 2012 31
19 juil. 2012 à 16:12

Ok merci bien, je test la macro mais à première vu cela répond parfaitement à ma demande.

pou pouille Messages postés 207 Date d'inscription mardi 20 octobre 2009 Statut Membre Dernière intervention 20 juillet 2012 31
20 juil. 2012 à 15:49

Macro testée, modifiée et Validée. encore une fois du travail de pro. Merci.
Pou Pouille

Discussions similaires

Pix

Trouver un nom avec une adresse

Comment trouver une adresse avec un nom de famille ?

logiciel de déshabillage de photo

Discussions similaires

Newsletters