XL 2016 Lister fichiers avec Exifs et propriétés (suivant son choix) - code à modifier

re4 · 27 Mars 2021

Edit 19/04/2021 : Les solutions sont aux posts #28 et #44 un grand merci à Dudu2

Bonjour à tous,
Je reviens avec une autre idée avec le code ci-dessous que j'ai légèrement modifé avec quelques annotations de débutant (que je suis ,-)
Cette macro fonctionne bien et extrait seulement les exifs que l'on désire avec quelque prérequis.

Je ne sais pas faire, vous est-il possible de m'aider et de la modifié pour :
1- Aller chercher le répertoire par l'ouverture d'une boite (explorer ?), à la place de : Set objFolder = objShell.Namespace("C:\Users\PC\Pictures\Test")
2- Lister à partir du dossier racine tous les fichiers de tous les sous répertoires.

Merci beaucoup

VB:

'original ?
    'https://www.excel-downloads.com/threads/macro-pour-extraire-l

    'Prérequis
    'créer une feuille ''Code'' avec en tête en ligne 1:
    'Colonne A les codes de toutes propriétés
    'Colonne B les noms de ces propriétés
    'Colonne C un X par exemple pour ne choisir que les plus utiles
    'Colonne D index par ordre de péférence (noms que l'on veut, puis tris de A-Z sur colonne D)
    'Colonne E les codes (colonne A) du tri de D

    ' Ne liste que le repertoire choisi (mais affiche les dossiers sous répertoire en nom)

    Sub LireExifTags5()
    Dim det_Headers(355)

    Sheets("Code").Select

    ' compte le nbre de cellule non vide de la colonne E de la feuille 'Code'
    LastRow = Cells(Rows.Count, 5).End(xlUp).Row

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace("C:\Users\PC\Pictures\Test")

    Workbooks(1).Sheets(1).Activate
        DernLigClear = Range("A" & Rows.Count).End(xlUp).Row

        Range("A2:OJ" & DernLigClear).ClearContents 'jusqu'a la colonne 400

    For i = 2 To LastRow
    c = i - 2
    k = Worksheets("Code").Cells(i, 5) 'Seulement les exifs que l'on désire

    det_Headers(c) = objFolder.GetDetailsOf(objFolder.Items, k)
    ActiveSheet.Cells(2, c + 1) = det_Headers(c) 'headers en ligne 2

    Workbooks(1).Sheets(1).Activate
    j = 3 ' pour datas en ligne 3

    For Each strFileName In objFolder.Items
    For m = 1 To LastRow
    Next

    Sheets(1).Cells(j, i - 1).Value = objFolder.GetDetailsOf(strFileName, k)

    j = j + 1

    Next
    Next

    'Columns("A:z").AutoFit
    ActiveSheet.UsedRange.EntireColumn.AutoFit
    End Sub

re4 · 25 Avril 2021

Un truc incompréhensible, j'ai supprimé le tif qui posait problème, ajouté 2 autres tif et ça a fonctionne parfaitement.
Puis re test avec l'ancien tif et tout fonctionne ... (???), il y a bien les 3 tif convertis par contre le msgbox de cet jamais lancé

Dudu2 · 26 Avril 2021

Si le message est placé comme indiqué et que tif fait partie de la 2ème ligne des paramètres il ne peut pas ne pas s'afficher.

Je ne sais pas pour ton code mais pour le mien:

re4 · 26 Avril 2021

Bonjour,
Je devais dormir hier soir... oui ça fonctionne
Test avec 3 tif poids = 165 Mo
Temps de conversion ~7'' soit un peu plus de 2" par tif
Poids du fichier Excel vierge 153 Ko
Poids du fichier Excel avec les 3 shaps 6284 Ko
La Dimension des shape n'influe pratiquement pas sur le poids final (test avec 50 et 400)
Un calcul approximatif donne ~2 Mo par shape ou miniature, c'est à mon avis encore trop sans compter les temps de calcul.
L'histoire n'est pas finie

MJ13 · 26 Avril 2021

Re

Sinon, ce code permet normalement de réduire la taille des images dans une feuille.

Il n'est pas viable de mettre plus de 100 images sur une feuille sans quelle soit réduite ou sans qu'on ai des ralentissements , surtout pour des images provenant d'un fichier non compressé.

VB:

Public Adr
'Option Private Module
Sub A_Réduit_Taille_Images()
Application.ScreenUpdating = False
N = ActiveSheet.Pictures.Count
For i = N To 1 Step -1
'MsgBox ActiveSheet.Pictures(i).Address
'Adr = ActiveSheet.Shapes(i).TopLeftCell.Address
ActiveSheet.Pictures(i).Select
Adr = ActiveSheet.Pictures(i).TopLeftCell.Address
ActiveSheet.Pictures(i).Select
Réduit_Image_Gif
DoEvents
Application.StatusBar = i
Next
'A voir si beaucoup d'images en cas de ralentissements, ne pas le faire
'Affecte_Images_Macro1
Application.StatusBar = N
'Place les images liés à la cellule
ActiveSheet.DrawingObjects.Select
Selection.Placement = xlMoveAndSize

Application.ScreenUpdating = True
Cells(1, 1).Select
End Sub
Private Sub Réduit_Image_Gif()
On Error Resume Next
    Selection.Cut
  Range(Adr).Select
  'ex: pour environ 25 images environ PNG = 2.6 Mo, JPG = 3.6 GIF = 0.28 Mo
    ActiveSheet.PasteSpecial Format:="Image (GIF)", Link:=False, DisplayAsIcon _
        :=False
        Selection.ShapeRange.IncrementLeft 2
        Selection.ShapeRange.IncrementTop 2
End Sub

re4 · 26 Avril 2021

MJ13 à dit:

Re

Sinon, ce code permet normalement de réduire la taille des images dans une feuille.

Il n'est pas viable de mettre plus de 100 images sur une feuille sans quelle soit réduite ou sans qu'on ai des ralentissements , surtout pour des images provenant d'un fichier non compressé.

VB:

Public Adr
'Option Private Module
Sub A_Réduit_Taille_Images()
Application.ScreenUpdating = False
N = ActiveSheet.Pictures.Count
For i = N To 1 Step -1
'MsgBox ActiveSheet.Pictures(i).Address
'Adr = ActiveSheet.Shapes(i).TopLeftCell.Address
ActiveSheet.Pictures(i).Select
Adr = ActiveSheet.Pictures(i).TopLeftCell.Address
ActiveSheet.Pictures(i).Select
Réduit_Image_Gif
DoEvents
Application.StatusBar = i
Next
'A voir si beaucoup d'images en cas de ralentissements, ne pas le faire
'Affecte_Images_Macro1
Application.StatusBar = N
'Place les images liés à la cellule
ActiveSheet.DrawingObjects.Select
Selection.Placement = xlMoveAndSize

Application.ScreenUpdating = True
Cells(1, 1).Select
End Sub
Private Sub Réduit_Image_Gif()
On Error Resume Next
    Selection.Cut
  Range(Adr).Select
  'ex: pour environ 25 images environ PNG = 2.6 Mo, JPG = 3.6 GIF = 0.28 Mo
    ActiveSheet.PasteSpecial Format:="Image (GIF)", Link:=False, DisplayAsIcon _
        :=False
        Selection.ShapeRange.IncrementLeft 2
        Selection.ShapeRange.IncrementTop 2
End Sub

Merci, je vais tester

re4 · 26 Avril 2021

Dudu2,
Voir le pdf joint
Ces suggestions ne sont pas obligatoires mais peuvent éventuellement servir suivant l’utilisation.
Le formatage ou la mise en forme est personnel, c’est toi qui décides de l’appliquer ou pas.
A ta disposition si besoin de l'UseFormots "Mots Clés'' pour gagner du temps.

Cela implique certainement beaucoup de travail pour modifier, fais comme tu as envie

Merci

Dudu2 · 26 Avril 2021

Pour la taille des miniatures, faut que je voie.
Ce qui est bizarre c'est que copiées dans Photofiltre par exemple elles ne font que 10-20 Ko mais que l'Excel qui les contient se prend 500 Ko par image, peut-être plus.
Je vais essayer de les enregistrer réduites avant de les charger.

J'ai trouvé, grâce à @patricktoulon, un moyen de" convertir les Raw.
Il faut installer une logiciel, ImageMagick, donc ce n'est pas direct, il faut maniper un peu.
La conversion prend environ 3 secondes ce qui est long. Mais on obtient un résultat.

patricktoulon · 26 Avril 2021

re
bonjour

Ce qui est bizarre c'est que copiées dans Photofiltre par exemple elles ne font que 10-20 Ko mais que l'Excel qui les contient se prend 500 Ko par image, peut-être plus.

non ce n'est pas bizarre c'est normal
une image insérée dans une feuille ou un load picture sur un activX c'est un bipmap qui est dans le bin du xls(m)

et le format bipmap est 10 fois plus lourd

re4 · 26 Avril 2021

Ce qui est bizarre c'est que copiées dans Photofiltre par exemple elles ne font que 10-20 Ko

Oui c'est ce que j'ai constaté aussi (post 117), c'est incompréhensible la miniature ne fait que 200px mais le fichier Excel fait presque le même poids que l'original, test 47 fichiers jpg = 69.30 Mo, fichier Excel 56.065 Mo !
C'est sûr que si l'on compresse avant on va gagner en poids
Exemple le même dossier de 47 photos compressées et redimensionnées en 200px dans sa plus grande def ne fait fait plus 461 Ko et le fichier Excel 514 Ko mais je ne traite que les jpg

re4 · 26 Avril 2021

patricktoulon à dit:
re
bonjour

non ce n'est pas bizarre c'est normal
une image insérée dans une feuille ou un load picture sur un activX c'est un bipmap qui est dans le bin du xls(m)

et le format bipmap est 10 fois plus lourd

Bonjour patricktoulon, nos réponses se sont croisées, quelle idée d'utiliser encore des bipmap !
D'après Wikipédia : introduit avec Windows 3.0 en 1990.

Y a quand même un truc que je ne comprends pas, lorsque l'on redimensionne, le poids est identique à l'original redimensionné, si j'ai compris ton message ça devrait être multiplié par 10 puisque le jpg serait converti en bmp ?

patricktoulon · 26 Avril 2021

re
bonjour re4 tu n'a rien compris
tu n'a pas le choix en fait
quand tu insert une picture jpeg ,c'est un bitmap dans le fichier xl
autrement dit si tu insert une picture de 200k par exemple
selon la chrominance en couleur ton fichier va peser 200k kilo *( entre 1 et 10) et tu n'y peux rien
et s

re4 · 26 Avril 2021

Oui, c'est ce que l'on constate mais je ne savais pas pourquoi, tu m'as éclairé

Dudu2 · 26 Avril 2021

une image insérée dans une feuille ou un load picture sur un activX c'est un bipmap qui est dans le bin du xls(m)

OK merci pour l'info. Je ne savais pas.

La solution c'est de ne pas insérer les miniatures dans la feuille en "statique", mais de ne le faire que pour les lignes visibles dynamiquement lorsqu'elles viennent à être affichées.

Ça va induire une certaine latence au scroll, latence qui d'ailleurs existe déjà le temps qu'Excel aille chercher ses petites choses de dessous les fagots pour afficher les images.

Évidemment en miniaturisation des d'images Raw cette latence sera significative.
Mais faut ce qu'il faut quand on veut ce qu'on veut !

Je verrai ça ce soir.

re4 · 26 Avril 2021

MJ13 à dit:

Re

Sinon, ce code permet normalement de réduire la taille des images dans une feuille.

Il n'est pas viable de mettre plus de 100 images sur une feuille sans quelle soit réduite ou sans qu'on ai des ralentissements , surtout pour des images provenant d'un fichier non compressé.

VB:

Public Adr
'Option Private Module
Sub A_Réduit_Taille_Images()
Application.ScreenUpdating = False
N = ActiveSheet.Pictures.Count
For i = N To 1 Step -1
'MsgBox ActiveSheet.Pictures(i).Address
'Adr = ActiveSheet.Shapes(i).TopLeftCell.Address
ActiveSheet.Pictures(i).Select
Adr = ActiveSheet.Pictures(i).TopLeftCell.Address
ActiveSheet.Pictures(i).Select
Réduit_Image_Gif
DoEvents
Application.StatusBar = i
Next
'A voir si beaucoup d'images en cas de ralentissements, ne pas le faire
'Affecte_Images_Macro1
Application.StatusBar = N
'Place les images liés à la cellule
ActiveSheet.DrawingObjects.Select
Selection.Placement = xlMoveAndSize

Application.ScreenUpdating = True
Cells(1, 1).Select
End Sub
Private Sub Réduit_Image_Gif()
On Error Resume Next
    Selection.Cut
  Range(Adr).Select
  'ex: pour environ 25 images environ PNG = 2.6 Mo, JPG = 3.6 GIF = 0.28 Mo
    ActiveSheet.PasteSpecial Format:="Image (GIF)", Link:=False, DisplayAsIcon _
        :=False
        Selection.ShapeRange.IncrementLeft 2
        Selection.ShapeRange.IncrementTop 2
End Sub

Je viens de tester, effectivement ça réduit le fichier Excel si l'on insère une photo le fichier passe de 1481 Ko à 438 Ko dans mon test.
Mais cela n'a aucune influence sur les shapes, voir aussi mail de PatrickToulon

re4 · 26 Avril 2021

Dudu2
Puisque on y est... sais-tu si l'on peut écrire dans les exifs d'un fichier photo jpg, dans titre, commentaires par exemple ? Bien sûr c'est possible avec les logiciels de traitement ou de catalogage photo mais avec une macro en vba ?

XL 2016 Lister fichiers avec Exifs et propriétés (suivant son choix) - code à modifier

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

Discussions similaires

Partager cette page

Statistiques des forums