Microsoft 365 Données photos

D

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
Trier par date Trier par votes
Staple1600

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
;)
 
Vote positif 0 Vote négatif
Staple1600

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 ;)
 
Vote positif 0 Vote négatif
patricktoulon

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

 
Vote positif 0 Vote négatif
Staple1600

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
 
Vote positif 0 Vote négatif
patricktoulon

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
 
Vote positif 0 Vote négatif
patricktoulon

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 ;)
 
Vote positif 0 Vote négatif
D

de_hanstrapp

XLDnaute Occasionnel
Staple1600 à dit:
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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
Staple1600

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
 
Vote positif 0 Vote négatif
D

de_hanstrapp

XLDnaute Occasionnel
Staple1600 à dit:
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
Cliquez pour agrandir...
Super !
Merci bcp.
Nsapg
 
Vote positif 0 Vote négatif

Discussions similaires

PHV.FSM
  • Question
XL 2016 Calculer la position sur l'écran d'une position sur la grille (XL 2003)
2
Réponses
27
Affichages
3 K
Nicolas JACQUIN
Nicolas JACQUIN
F
  • Question
Suivie de recouvrement des creances aupres des clients
Réponses
2
Affichages
18 K
Kimadi
K
M
[REF] Wiki Page 7 de MichelXld
Réponses
0
Affichages
51 K
MichelXld
M
M
[REF] Wiki 2 de MichelXld (Ce qui touche aux UserForm)
Réponses
0
Affichages
116 K
MichelXld
M
M
[REF] Wiki 6 de MichelXld (Doublons, Tris, Filtres, Variables, Fichiers fermés, Acces
Réponses
0
Affichages
68 K
MichelXld
M

Membres actuellement en ligne

14 membres et 178 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 767
Messages
2 112 728
Membres
111 647
dernier inscrit
ndfatou03