Discussion :

[re]

Bonjour,
Je ne sais pas plus ou j'ai récupéré ce bout de code

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)

Je voudrai remplacer 'Set objfolder = objShell.Namespace("C:\Users\Utilisateur\Pictures\test"), pour aller chercher l'image jpg (test_img.jpg par exemple) qui se trouve dans le répertoire courant, là ou ce trouve le fichier xlsm, mais mon niveau VBA ne me le permet pas encore ;-)
Pour que le fichier puisse être utilisé sur n'importe quel PC, je ne voudrai pas que le chemin soit inscrit dans le code.
Pouvez-vous m'aider ?
Merci
bon WE

[Theze]

Bonjour,

Une piste :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
 
Sub Test()
 
    Dim Chemin As String
 
    'construit le chemin
    Chemin = ThisWorkbook.Path & "\" & "test_img.jpg"
 
    'contrôle la présence du fichier dans le dossier
    If Dir(Chemin) <> "" Then MsgBox "Le fichier se trouve bien dans le dossier du calsseur"
 
End Sub

[re]

Merci pour ta rapide réponse mais je l'insère ou et à la place de quoi ?

Voici la macro complete

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Code_champs_proprietes()
Sheets("Code").Select
[B2:C310].ClearContents
 
Dim det_Headers(300)
 
Set objShell = CreateObject("Shell.Application")
Workbooks(1).Sheets(1).Activate
 Set objfolder = objShell.Namespace("C:\Users\Utilisateur\Pictures\test")        ' idéalement il faudrait aller chercher l'image jpg dans le repertoire ou est situé le fichier xlsm 
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

[Theze]

Il te suffit de remplacer :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Set objfolder = objShell.Namespace("C:\Users\Utilisateur\Pictures\test")

par :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Set objfolder = objShell.Namespace(ThisWorkbook.Path & "\")

[re]

Merci,
Effectivement ça fonctionne mais ça liste tous les fichiers qu'il y a dans le repertoire, je ne voudrai lister qu'une seule photo ex: test_img.jpg

Cela me permet de récupérer tous les codes de champs des propriétés ils sont différents suivant l'OS ou les offices utilisés (?)
Jusqu'à présent je pouvais le gérer mais je ne sais pas pourquoi ces codes changent

[Theze]

Comme tu demandais d'utiliser le code que tu avais posté, j'en avais déduit que c'était ce que tu souhaitais comme résultat !
Pour insérer une image dans une feuille de calcul :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 
Sub Test()
 
    Dim Chemin As String
    Dim NomImg As String
 
    'nom de l'image
    NomImg = "test_img.jpg"
 
    'construit le chemin
    Chemin = ThisWorkbook.Path & "\" & NomImg
 
    'contrôle la présence du fichier dans le dossier
    If Dir(Chemin) <> "" Then ActiveSheet.Pictures.Insert Chemin
 
End Sub

[re]

Pardon, Je crois que l'on c'est mal compris, je n'ai pas été assez précis, je veux utiliser le code que j'ai posté mais aller chercher une seule image

Lorsque j'insère la ligne ci-dessous ça liste tous les fichiers

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set objfolder = objShell.Namespace(ThisWorkbook.Path & "\")

Je ne sais pas utiliser ton dernier code pour l'inclure dans la macro, j'ai essayé mais j'ai une erreur au lancement

Merci encore

[Theze]

Tu veux quoi au juste, énumérer les propriétés du fichier image ou insérer l'image dans une feuille Excel ?

[re]

Exactement ce que tu as fait avec le code ci-dessous mais ne pas lister tout le repertoire mais choisir un seul fichier.

Donc pour répondre à ta question je veux énumérer les propriétés d'une seule image et uniquement test_img.jpg par exemple qui se trouve dans le repertoire du fichier xlsm

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set objfolder = objShell.Namespace(ThisWorkbook.Path & "\")

Ce code liste tout le répertoire et ce n'est pas ce que je veux

Merci

[kiki29]

Salut, s'il ne s'agit que de cela, voir Liste des propriétés de fichiers, éventuellement à adapter à ton contexte, tout est indiqué dans le module concerné.

[re]

Merci pour ta réponse et le lien, non il ne s'agit pas que de ça le mode d'extraction je l'ai en beaucoup plus simple, la macro de ce post.

Cette macro fonctionne bien, j'en ai besoin pour valider la liste de champs des propriétés Exifs, je ne sais pas pourquoi mais Microsoft a changé les codes (il sont déférents sur deux PC avec Win 10 mais pas la même version) Peut être aussi que la version d'office a une incidence ?.
Il faut donc que quand je lance mon fichier xlsm j'identifie le numéro de champs en foncions du PC avant d'extraire les champs qui m'intéressent qui eux vont servir à construire un tableau avec une autre macro .
La base de la macro que j'ai posté est simple mais je ne sais pas lui dire d'aller chercher le fichier test_img.jgg dans le répertoire du fichier excel.
Macro 1 => extraction des codes exifs d'une seule photo à partir de n'importe quel Pc, c'est celle qui m'intéresse et qui sera lancée en 1er
Macro 2 existante et fonctionnelle => récupère ces codes et construit un tableau avec tous les fichiers jpg d'un repertoire.
Je ne vois pas d'autres solutions pour rendre ce fichier compatible sur les PC et OS différents

NB : les codes exifs de la largeur et hauteur pixels de win7, 8, 10 sont différents ! Allez savoir pourquoi, Microsoft à certainement une raison...

Merci à vous tous

[kiki29]

Re, à part que ce n'est pas 300 la limite actuelle mais plutôt 315 ..... bref elle "marche" mais pas complètement ni correctement.

[re]

Bonsoir Kiki29
Je ne sais pas de quoi tu parles exactement que ce soit 300 ou 315, ça ne change rien à ma demande, et puis le fameux lien que tu as si gentiment donné oui il fonctionne mais sur un environnement 32 bits, il faut modifier des trucs dont je ne suis pas capable pour le faire fonctionner en 64 bits.

Theze, n'était vraiment pas loin du but, c'est exactement ce que je voulais seulement il faut utiliser ThisWorkBook et ne lire qu'une seule image dont on aura donné le nom et pas scanner tout le repertoire

[Theze]

Bonjour,

Teste ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 
 
Sub Code_champs_proprietes()
 
    Dim NomImg As String
 
    'nom de l'image
    NomImg = "test_img.jpg"
 
    Sheets("Code").Select
    [B2:C310].ClearContents
 
    Set objShell = CreateObject("Shell.Application")
    Set objfolder = objShell.Namespace(ThisWorkbook.Path & "\")
 
    For Each strFilename In objfolder.Items
 
        If strFilename = NomImg Then
 
            For I = 0 To 300
                ActiveSheet.Cells(I + 1, 1) = objfolder.GetDetailsOf(objfolder.Items, I - 1)
                Sheets(1).Cells(I + 2, 2).Value = objfolder.GetDetailsOf(strFilename, I)
            Next I
 
        End If
 
    Next strFilename
 
End Sub

[re]

Bonjour Theze
Merci beaucoup pour ta réponse mais ça me dit sub ou Fonction non défini,
Bonne journée

[re]

Bonjour,
Je viens de m'apercevoir que dans mon environnement, je suis obligé de supprimer les espaces entre les lignes et tout aligner à gauche, certaines lignes en retrait sont en rouges.
Avez-vous une explication ?

Pc 64 bits/ Win 10 / Visual Basic 7.1

Merci

[Theze]

Bonjour,

Merci beaucoup pour ta réponse mais ça me dit sub ou Fonction non défini,

Sur quelle instruction ?

Je viens de m'apercevoir que dans mon environnement, je suis obligé de supprimer les espaces entre les lignes et tout aligner à gauche, certaines lignes en retrait sont en rouges.
Avez-vous une explication ?

C'est bien la première fois que je lis ça !
Postes le code comme tu l'as dans l'éditeur !
Attention, le classeur sur lequel tu fais tes tests doit être enregistré, logique pour pouvoir en récupérer son chemin

[re]

Bonsoir,
Oui, je sais, c'est étrange...
En capture jointe le code original avec l'erreur au lancement (capture1) et le même code aligné à gauche qui fonctionne bien (capture2)
Bien sur le fichier xlsm est enregistré et l'image test est bien présente, la feuille est bien nommée ''Code''.
Sur certains codes, la ligne en retrait est en rouge, si j'aligne tout à gauche ça marche (c'est une infos, je n'ai pas le code sous la main)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub Code_champs_proprietes()
Dim NomImg As String
'nom de l'image
NomImg = "test_img.jpg"
Sheets("Code").Select
[B2:C310].ClearContents
Set objShell = CreateObject("Shell.Application")
Set objfolder = objShell.Namespace(ThisWorkbook.Path & "\")
For Each strFilename In objfolder.Items
If strFilename = NomImg Then
For I = 0 To 300
ActiveSheet.Cells(I + 1, 1) = objfolder.GetDetailsOf(objfolder.Items, I - 1)
Sheets(1).Cells(I + 2, 2).Value = objfolder.GetDetailsOf(strFilename, I)
Next I
End If
Next strFilename
End Sub

Au lancement de la macro, à chaque fois que je supprime l'espace et que j'aligne à gauche, le curseur se positionne sur la prochaine ligne vide
:

Le même code ou tout est OK



Merci

[Theze]

Bonjour,

As tu essayé le code sur un autre PC ou un autre classeur vierge ?
Là, je ne peux pas t'aider car je n'ai aucune idée de quoi ça peut venir

[re]

Bonjour,
Oui sur un PC win10 32 bits (office pro 2010) et 64 bits (office 2016) et à chaque fois avec un classeur vierge.
Mystère donc...