Microsoft 365 Données photos

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

'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

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

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

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

For i = 0 To 34
    If myFolder.GetDetailsOf(myFile, i) <> "" Then _
    Cells(1, i + 1) = myFolder.GetDetailsOf(myFile, i)
Next

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

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