XL 2016 Extraire propriété d'une seule image dans repertoire courant

re4

XLDnaute Occasionnel
Bonjour,
Je ne sais pas ou j'ai récupéré cette macro, elle fonction très bien mais il faudrait faire une petite modification que mon niveau VBA ne me permet pas.
Il faudrait extraire les propriétés d'une seule photo qui se trouve dans le repertoire du fichier xlsm.
actuellement cette macro liste tous les fichiers du repertoire.
Il faudrait peut être modifier cette ligne
Set objfolder = objShell.Namespace("C:\Users\Utilisateur\Pictures\test")
pour aller chercher la photo test.jpg uniquement qui est dans le même repertoire que le fichier xlsm

Code:
Sub Code_champs_proprietes()
Sheets("Code").Select
[B2:C310].ClearContents

Dim det_Headers(300)

Set objShell = CreateObject("Shell.Application")
Set objfolder = objShell.Namespace("C:\Users\Utilisateur\Pictures\test")
Workbooks(1).Sheets(1).Activate
For i = 0 To 300
det_Headers(i) = objfolder.GetDetailsOf(objfolder.Items, i - 1)
ActiveSheet.Cells(i + 1, 2) = det_Headers(i)

Next
Workbooks(1).Sheets(1).Activate
j = 3 'colonne
For Each strFilename In objfolder.Items
For i = 0 To 300
Sheets(1).Cells(i + 2, j).Value = objfolder.GetDetailsOf(strFilename, i)
Next
j = j + 1
Next
End Sub

Merci de votre aide
 

Staple1600

XLDnaute Barbatruc
Bonsoir le fil, le forum

En farfouillant un peu dans mes favoris et en attendant le film du dimanche soir
Lancer la macro nommée Test_OK
(en ayant pris soin de faire les changements nécessaires
- voir commentaires en vert)

VB:
Sub Test_OK()
'ici remplacer par le chemin du dossier puis par le nom de l'image
'ne pas oublier le \ de fin et l'extension de l'image
Lire_IMG "C:\Users\STAPLE\Pictures\NICEPHORE\", "CIMG0616.JPG"
End Sub
Private Sub Lire_IMG(Chemin$, NomIMG$)
Dim t, tt
t = Split(Lire_Proprietes_IMG(Chemin & NomIMG, 0), ";")
tt = Split(Lire_Proprietes_IMG(Chemin & NomIMG, 39), ";")
Range("A1").Resize(UBound(t)) = Application.Transpose(t)
Range("B1").Resize(UBound(tt)) = Application.Transpose(tt)
End Sub
Function Lire_Proprietes_IMG(strFilewFullPath, iDoHeaders As Integer)
'fonction originale:GetFileProperties2
'par Shasur M
Const arrSize = 39
Dim strFile$, strFileName, strPath$, sTemp As Variant, I%, fsize%
Dim idate As Date, idimension$, Camera$, objShell As Object
Dim arrHeaders(arrSize)
Dim objFolder As Object, oFile As Object, arTemp
Set objShell = CreateObject("Shell.Application") '=====
strFile = Dir(strFilewFullPath)
strPath = Left(strFilewFullPath, InStrRev(strFilewFullPath, "\") - 1)
arTemp = Split(strFilewFullPath, "\")
strFileName = arTemp(UBound(arTemp))
Set objFolder = objShell.Namespace(strPath & "\")
For I = 0 To arrSize
  arrHeaders(I) = objFolder.GetDetailsOf(objFolder.Items, I)
Next I
Lire_Proprietes_IMG = ""
Set oFile = objFolder.ParseName(strFileName)

For I = 0 To arrSize
  sTemp = arrHeaders(I)
  If iDoHeaders = 0 Then
    If IsNull(sTemp) Or sTemp = "" Then sTemp = "Manquant"
    Lire_Proprietes_IMG = Lire_Proprietes_IMG & sTemp & ";"
   Else
    sTemp = objFolder.GetDetailsOf(oFile, I)
    If IsNull(sTemp) Then sTemp = "Manquant"
    Lire_Proprietes_IMG = Lire_Proprietes_IMG & sTemp & ";"
   End If
Next I
End Function
 
Dernière édition:

re4

XLDnaute Occasionnel
Merci d'avoir répondu Staple1600, mais il faut rentrer un chemin, ce que je ne souhaite pas pour que ce soit le plus universel possible.
Vu ailleurs, je pense qu'il utiliser ThisWorkBook par exemple:
Set objfolder = objShell.Namespace(ThisWorkbook.Path & "\")
Seulement cette ligne scanne tout le répertoire, je ne voudrai les propriétés que d'une seule photo comme dit plus haut

Bonne soirée
 

Staple1600

XLDnaute Barbatruc
Re,

@re4
Seulement cette ligne scanne tout le répertoire, je ne voudrai les propriétés que d'une seule photo comme dit plus haut
C'est ce que fait mon code, camarade !!!

Je pensais que tu ferais toi-même le changement nécessaire...:eek::rolleyes:
VB:
Sub Test_OK_B()
'ici remplacer par le chemin du dossier puis par le nom de l'image
'ne pas oublier le \ de fin et l'extension de l'image
Dim strPath$
strPath = ThisWorkbook.Path & "\"
Lire_IMG strPath, "CIMG0616.JPG"
End Sub
 
Dernière édition:

re4

XLDnaute Occasionnel
C'est ce que j'ai fait j'ai fait, et j'ai l'erreur au lancement de la macro

VB:
Sub Test_OK_B()
'ici remplacer par le chemin du dossier puis par le nom de l'image
'ne pas oublier le \ de fin et l'extension de l'image
Dim strPath$
strPath = ThisWorkbook.Path & "\"
Lire_IMG strPath, "Control_img.jpg"
End Sub
Function Lire_Proprietes_IMG(strFilewFullPath, iDoHeaders As Integer)
'fonction originale:GetFileProperties2
'par Shasur M
Const arrSize = 39
Dim strFile$, strFileName, strPath$, sTemp As Variant, I%, fsize%
Dim idate As Date, idimension$, Camera$, objShell As Object
Dim arrHeaders(arrSize)
Dim objFolder As Object, oFile As Object, arTemp
Set objShell = CreateObject("Shell.Application") '=====
strFile = Dir(strFilewFullPath)
strPath = Left(strFilewFullPath, InStrRev(strFilewFullPath, "\") - 1)
arTemp = Split(strFilewFullPath, "\")
strFileName = arTemp(UBound(arTemp))
Set objFolder = objShell.Namespace(strPath & "\")
For I = 0 To arrSize
  arrHeaders(I) = objFolder.GetDetailsOf(objFolder.Items, I)
Next I
Lire_Proprietes_IMG = ""
Set oFile = objFolder.ParseName(strFileName)
For I = 0 To arrSize
  sTemp = arrHeaders(I)
If iDoHeaders = 0 Then
If IsNull(sTemp) Or sTemp = "" Then sTemp = "Manquant"
Lire_Proprietes_IMG = Lire_Proprietes_IMG & sTemp & ";"
Else
sTemp = objFolder.GetDetailsOf(oFile, I)
If IsNull(sTemp) Then sTemp = "Manquant"
Lire_Proprietes_IMG = Lire_Proprietes_IMG & sTemp & ";"
End If
Next I
End Function
 

Staple1600

XLDnaute Barbatruc
Re

@re4
Ça devient pénible (ou risible) ;)
(à moins que tu ne sois myope :rolleyes:)
Tu n'as pas copié intégralité du code VBA présent dans le message#2!!!
Où est cette partie?
VB:
Private Sub Lire_IMG(Chemin$, NomIMG$)
Dim t, tt
t = Split(Lire_Proprietes_IMG(Chemin & NomIMG, 0), ";")
tt = Split(Lire_Proprietes_IMG(Chemin & NomIMG, 39), ";")
Range("A1").Resize(UBound(t)) = Application.Transpose(t)
Range("B1").Resize(UBound(tt)) = Application.Transpose(tt)
End Sub
 

Staple1600

XLDnaute Barbatruc
Re

Le $ est déjà dans la déclaration de variable
Donc non pas besoin de rajouter de $

La prochaine fois, n'oublie pas tes lunettes ;)

PS: Heureusement pour moi, je n'ai pas de patiente auprès de moi.
Et ce n'est pas de la patience, mais du désœuvrement en attendant de voir un truc potable à la TV ce soir.
 

Staple1600

XLDnaute Barbatruc
Re

Histoire de varier les plaisirs et d'aller un chouia plus loin
(et de saluer un ancien d'ici: SilkyRoad aka MichelXLD)
VB:
Sub Pour_Les_Photographes()
'+++++++++++++++++++++++++++++++++++++++
'adapté du code SilkyRoad
'cocher la référence à WIA Library
'C:\Windows\System32\wiaaut.dll
'+++++++++++++++++++++++++++++++++++++++
Dim Img As Object, P As Property, S$, t
'Création conteneur pour l'image à manipuler
    Set Img = CreateObject("WIA.imageFile")
    'Chargement de l'image dans le conteneur
    Img.LoadFile ("C:\Users\STAPLE\Pictures\CIMG0616.JPG")
    'Boucle sur la collection de propriétés
    For Each P In Img.Properties
        S = P.Name & "(" & P.PropertyID & ") = "
        If P.IsVector Then
            S = S & " * vector data not emitted * "
            ElseIf P.Type = RationalImagePropertyType Then
            S = S & P.Value.Numerator & "/" & P.Value.Denominator
            ElseIf P.Type = StringImagePropertyType Then
            S = S & """" & P.Value & """"
            Else
            S = S & P.Value
        End If
        tt = tt & S & "²"
    Next
  t = Split(tt, "²")
  Range("A1").Resize(UBound(t)) = Application.Transpose(t)
  Range("A1").CurrentRegion.TextToColumns _
        Destination:=Range("A1"), DataType:=xlDelimited, Other:=True, _
        OtherChar:="=", FieldInfo:=Array(Array(1, 1), Array(2, 2))
End Sub
 

Discussions similaires

Haut Bas