Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Microsoft 365 Données photos

de_hanstrapp

XLDnaute Occasionnel
Bonsoir le forum,

Dans le cadre d'un projet, je dois vérifier la taille et les dimensions de centaines de photos contenus dans un dossier.
Mon objectif est d’intégrer dans le fichier Excel joint, son nom, sa taille, son rapport et sa résolution afin de m'indiquer rapidement si la photo est aux normes requises où non.
J'ai parcouru le forum et d'autres sites internet mais je n'ai pas réussi à obtenir le résultat escompté (j'ai essayé avec un fichier .bat pour la taille mais je n'arrive pas à obtenir sa résolution). Pensez-vous que cela soit possible ?

Infos + : pour être conforme la taille doit être comprise entre 500 kb et 1,5 mb pour un rapport largeur/hauteur de 4/5 et une dimension minimum de 480 pixels/600 pixels

Merci par avance pour vos remarques et retours !

NSAPG
 

Pièces jointes

  • Exemple.xlsm
    9.7 KB · Affichages: 32

Staple1600

XLDnaute Barbatruc
Bonjour le fil

=>patricktoulon
Ce n'est pas mon code
C'est écrit dans le message de 2009 que je cite.
Ceci dit j'aurai du le tester avant de le citer en 2009 et en le re-citant 11 ans après

C'est pas grave, tu dois avoir ce qu'il faut dans tes archives
Avec la librairie WindowsImageAcquisition
 

Staple1600

XLDnaute Barbatruc
Re

En guise de pénitence dominicale
Code modifié et testé en 2021
VB:
Sub LireInfosJpg_OK()
''Dans outil réferences cocher Microsoft Shell Controls and Automation
Dim myShell As Shell, myFolder As Object, myFile As Object
Dim i As Byte, Chemin$, f, lig&
'Indiquer le chemin du répertoire
Chemin = "C:\Users\STAPLE\Pictures\Tests\" 'adapter le chemin
Set myShell = CreateObject("Shell.Application")
Set myFolder = myShell.Namespace(Chemin)
ActiveSheet.UsedRange.Clear
Application.ScreenUpdating = False
For i = 0 To 34
    If myFolder.GetDetailsOf(myFile, i) <> "" Then _
    Cells(1, i + 1) = myFolder.GetDetailsOf(myFile, i)
Next
f = Dir(Chemin & "\*.jpg")
Do While Len(f) > 0
Set myFile = myFolder.Items.Item(f)
lig = Cells(Rows.Count, 1).End(xlUp)(2).Row
For i = 0 To 34
    If myFolder.GetDetailsOf(myFile, i) <> "" Then _
    Cells(lig, i + 1) = myFolder.GetDetailsOf(myFile, i)
Next
f = Dir
Loop
Set myShell = Nothing
Set myFolder = Nothing
Set myFile = Nothing
End Sub
Le code fonctionne.
Ensuite, il faut faire un peu de ménage dans les 36 colonnes
Ou utiliser un autre code
 

patricktoulon

XLDnaute Barbatruc
re
oui avec wia j'ai le size en pixel pas de soucis
fonction pour les dimensions de l'image
VB:
'patricktoulon VBA  et Images
Type DimT: largeur As Double: hauteur As Double: End Type
Function dimention_image(fichier) As DimT
    Dim Img As Object, d As DimT
    With CreateObject("WIA.ImageFile"):    .LoadFile fichier:     d.largeur = .width: d.hauteur = .height: dimention_image = d: End With
End Function
Fonction pour le poids de l'image
Code:
Function getpoids(fichier)
On Error GoTo err
Dim oFSO As Object, oFl As Object, t
With CreateObject("Scripting.FileSystemObject")
Set oFl = .GetFile(fichier)
t = oFl.Size / 1000: e = IIf(t > 1000, " mega", " Kilo")
getpoids = t & e
End With
fin:
 Exit Function
err:
        Select Case err.Number
            Case 53: getpoids = "Le fichier est introuvable"
            Case Else: getpoids = "Erreur inconnue"
        End Select
    Resume fin
End Function

la sub pour tester les deux fonctions
Code:
Sub test()
'get size
Dim fichier$, d As DimT, Poids
fichier = "H:\fond_d_ecran\animaux\cheval2.jpg"
d = dimention_image(fichier)
MsgBox "width : " & d.largeur & vbCrLf & "Height : " & d.hauteur

Poids = getpoids(fichier)
MsgBox "poids du fichier :" & Poids
End Sub

 

Staple1600

XLDnaute Barbatruc
Re

La version avec nettoyage
VB:
Sub LireInfosJpg_OK_bis()
'Dans outil réferences cocher Microsoft Shell Controls and Automation
Dim myShell As Shell, myFolder As Object, myFile As Object
Dim i As Byte, Chemin$, f, lig&
'Indiquer le chemin du répertoire
Chemin = "C:\Users\STAPLE\Pictures\Tests\"
Set myShell = CreateObject("Shell.Application")
Set myFolder = myShell.Namespace(Chemin)
ActiveSheet.UsedRange.Clear
Application.ScreenUpdating = False
For i = 0 To 34
    If myFolder.GetDetailsOf(myFile, i) <> "" Then _
    Cells(1, i + 1) = myFolder.GetDetailsOf(myFile, i)
Next
f = Dir(Chemin & "\*.jpg")
Do While Len(f) > 0
Set myFile = myFolder.Items.Item(f)
lig = Cells(Rows.Count, 1).End(xlUp)(2).Row
For i = 0 To 34
    If myFolder.GetDetailsOf(myFile, i) <> "" Then _
    Cells(lig, i + 1) = myFolder.GetDetailsOf(myFile, i)
Next
f = Dir
Loop
Range("D:D,F:L,N:AD,AH:AJ").Delete Shift:=xlToLeft
Cells(1).CurrentRegion.Columns.AutoFit
Cells(1).Select
Set myShell = Nothing
Set myFolder = Nothing
Set myFile = Nothing
End Sub
 

patricktoulon

XLDnaute Barbatruc
re
c'est quand même extraordinaire a quel point vb est permissif avec certains com
le nom des properties
VB:
For i = 0 To 34
    If myFolder.GetDetailsOf(myFile, i) <> "" Then _
    Cells(1, i + 1) = myFolder.GetDetailsOf(myFile, i)
Next
traduction
If myFolder.GetDetailsOf(rien dutout, i) <> "" Then _
Cells(1, i + 1) = myFolder.GetDetailsOf(rien du tout , i)


celui qui sait pas ; ben il en perd ses cheveux
 

patricktoulon

XLDnaute Barbatruc
re
par contre un truc que j'ai jamais trouvé c'est le faire en late binding
démonstration
VB:
Sub test()
dossier$ = "H:\fond_d_ecran\animaux"
fichier$ = "cheval2.jpg"
MsgBox GetProperty(dossier, fichier, "Dimensions")
End Sub

Function GetProperty(strFolder As String, strFile As String, Propertys As String) As String
    Dim objShell As New Shell
    Dim objFolder
    Dim objFile
     Set objFolder = objShell.Namespace(strFolder)
    Set objFile = objFolder.ParseName(strFile)
    GetProperty = objFile.ExtendedProperty(Propertys)
End Function

'---------------------------------------
'version late binding
Sub test2()
dossier$ = "H:\fond_d_ecran\animaux"
fichier$ = "cheval2.jpg"
MsgBox GetProperty2(dossier, fichier, "Dimensions")
End Sub

Function GetProperty2(strFolder As String, strFile As String, Propertys As String) As String
    Dim objShell As Object
    Dim objFolder
    Dim objFile
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(strFolder)
    Set objFile = objFolder.ParseName(strFile) '!!!!!!!!!!!!!ERREUR (91)!!!!!!!!!!
    GetProperty2 = objFile.ExtendedProperty(Propertys)
End Function
celui qui sais c'est mon ami
 

de_hanstrapp

XLDnaute Occasionnel
Bonsoir Staple1600,
Bonsoir le forum,

Merci bcp pour cette aide et le code avec le nettoyage.
Je l'ai adapté à mon fichier et à mes formats d'image.

Sub LireExifPhotos()
Dim myShell As Shell, myFolder As Object, myFile As Object
Dim i As Byte, Chemin$, f, lig&
Chemin = "C:\Users\xxx\Desktop\PHOTOS"
Set myShell = CreateObject("Shell.Application")
Set myFolder = myShell.Namespace(Chemin)
ActiveSheet.UsedRange.Clear
Application.ScreenUpdating = False
For i = 0 To 34
If myFolder.GetDetailsOf(myFile, i) <> "" Then _
Cells(1, i + 1) = myFolder.GetDetailsOf(myFile, i)
Next
f = Dir(Chemin & "\*.*")
Do While Len(f) > 0
Set myFile = myFolder.Items.Item(f)
lig = Cells(Rows.Count, 1).End(xlUp)(2).Row
For i = 0 To 34
If myFolder.GetDetailsOf(myFile, i) <> "" Then _
Cells(lig, i + 1) = myFolder.GetDetailsOf(myFile, i)
Next
f = Dir
Loop
Range("D:AE,AG:AI").Delete Shift:=xlToLeft
Cells(1).CurrentRegion.Columns.AutoFit
Cells(1).Select
Set myShell = Nothing
Set myFolder = Nothing
Set myFile = Nothing
End Sub


J'ai une dernière requête...
Plutôt que d'indiquer une chemin prédéfini, est il envisageable de modifier le code pour sélectionner manuellement le dossier dans lequel se trouvent les photos ?
Si oui, possibilité de m'aider ?

Merci par avance.

Nsapg
 

Staple1600

XLDnaute Barbatruc
Bonsoir le fil

NB: J'avais fait une erreur de copier/coller ( houps )
C'est Application.FileDialog(msoFileDialogFolderPicker) et non pas Application.Get...
Test OK chez moi
VB:
Sub LireInfosJpg_OK_BIS()
''Dans outil réferences cocher Microsoft Shell Controls and Automation
Dim myShell As Shell, myFolder As Object, myFile As Object
Dim i As Byte, Chemin$, f, lig&, rep_JPG$

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choisir le dossier Images"
.InitialFileName = ""
If .Show Then rep_JPG = .SelectedItems(1) Else Exit Sub
End With

Chemin = rep_JPG & "\"
Set myShell = CreateObject("Shell.Application")
Set myFolder = myShell.Namespace(Chemin)
ActiveSheet.UsedRange.Clear
Application.ScreenUpdating = False
For i = 0 To 34
    If myFolder.GetDetailsOf(myFile, i) <> "" Then _
    Cells(1, i + 1) = myFolder.GetDetailsOf(myFile, i)
Next
f = Dir(Chemin & "\*.jpg")
Do While Len(f) > 0
Set myFile = myFolder.Items.Item(f)
lig = Cells(Rows.Count, 1).End(xlUp)(2).Row
For i = 0 To 34
    If myFolder.GetDetailsOf(myFile, i) <> "" Then _
    Cells(lig, i + 1) = myFolder.GetDetailsOf(myFile, i)
Next
f = Dir
Loop
Set myShell = Nothing
Set myFolder = Nothing
Set myFile = Nothing
End Sub
 

de_hanstrapp

XLDnaute Occasionnel
Super !
Merci bcp.
Nsapg
 
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…