Importer des photos avec description
Bonjour à tous,
Après beaucoup de recherche, je n'arrive pas à trouver la solution à ce que je souhaite faire.
Je dois créer un tableau avec 3 colonnes : Nom - Photo - Date, jusqu'à la facile. Mais il faut que j'importe plus d'une centaine de photos dans ce tableau avec le nom de la photo ainsi que la date. Toutes les photos à importer sont dans un seul et même dossier sur mon serveur au format JPG.
Je pourrais faire ça à la main pour chaque photo mais ce n'est pas l'idéal.
J'ai vu qu'il existe des VBA, mais rien ne fonctionne. Avez-vous une solution à mon problème ?
Salut,
Le nom et la date des photos sont-ils récupérables via le nom du fichier jpg ?
Bonjour,
Pour ce qui est d'importer le nom des photos (sans extension) et leur date, voici une macro.
Je n'ai pas bien compris quel était le 3e paramètre (photo) : faut-il mettre les photos dans une cellule ? S'agit-il dans ce cas de miniature genre photo d'identité ?
Si le nom des photos doit être complet, donc avec extension au cas où il y aurait des .jpeg et des .jpg mélangés, il faudra le dire.
Option Explicit
Sub Macro1()
Dim f As Object, fso As Object
Dim folder As String, nomFic() As String, nL As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then MsgBox "Importation annulée.": ws.Cells.Clear: End
ws.Cells.Clear
Cells(1, 1) = "Fichier": Cells(1, 2) = "Date"
folder = .SelectedItems(1)
End With
For Each f In fso.GetFolder(folder).Files
nomFic = Split(f.Name, ".")
nL = ActiveSheet.Cells(Columns.Count, 1).End(xlUp).Row + 1
ws.Range("A" & nL) = nomFic(0)
ws.Range("B" & nL) = Left(FileDateTime(folder & "\" & f.Name), 10)
Next f
Columns("A:B").Columns.AutoFit
End SubBonjour,
Oui il faudrait insérer la photo dans une cellule. Du genre cellule 1 : titre (nom du fichier) ; cellule 2 : photo (miniatures); cellule 3 : date (enregistrement de la photo).
Miniature n'est pas assez précis. Le script ci-dessous fonctionne par exemple avec des images en 100x100 pixels.
Option Explicit
Sub Macro1()
Dim f As Object, fso As Object, p As Object
Dim h As Double, b As Double, g As Double, d As Double ' Haut, bas, gauche, droite
Dim folder As String, nomFic() As String, fullName As String, nL As Integer
Dim wS As Worksheet, cellule As Range
Set wS = ActiveSheet
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then MsgBox "Importation annulée.": wS.Cells.Clear: End
wS.Cells.Clear
Cells(1, 1) = "Fichier"
Cells(1, 2) = "Photo"
Cells(1, 3) = "Date"
folder = .SelectedItems(1)
End With
For Each f In fso.GetFolder(folder).Files
nomFic = Split(f.Name, ".")
nL = ActiveSheet.Cells(Columns.Count, 1).End(xlUp).Row + 1
wS.Range("A" & nL) = nomFic(0)
wS.Range("C" & nL) = Left(FileDateTime(folder & "\" & f.Name), 10)
fullName = folder & "\" & f.Name
Set cellule = wS.Range("B" & nL)
cellule.Select
Set p = wS.Pictures.Insert(fullName)
cellule.ColumnWidth = p.Width * 52 / 288 ' La valeur 52 est à ajuster
cellule.RowHeight = p.Height
Next f
wS.Columns("A").Columns.AutoFit
wS.Columns("C").Columns.AutoFit
End SubMiniature, par exemple que la photo ai un format de 6cm sur 8cm.
Il m'indique une erreur sur cette ligne et je ne vois pas a quoi elle correspond.
cellule.RowHeight = p.HeightQuand j'ai testé le code, seulement la première photo du dossier a été importé, s'agit-il de ce code ?
La ligne du fichier Excel, peut-elle s'ajuster automatiquement à la taille de la photo ? (sur la capture d'écran, j'ai réduit la taille de la photo car celle-ci été bien plus grande).
Peut-être tes images sont-elles trop grandes. Chez moi, sur un dossier contenant 200 vignettes en 100x100 pixels, ça fonctionne.
Oui en effet, je vient d'essayer en modifiant les pixels des photos cela fonctionne. Cependant les photos ne sont plus du tout lisibles. En étudiant le code, je ne vois pas si cela peut être modifié ?
Bonjour à tous,
Voici un essai en utilisant la méthode .addpicture au sein de la dernière boucle adaptée du code d'Optimix (que je salue !) :
'déclarations
dim maxwidth as double
'début du code
For Each f In fso.GetFolder(folder).Files
nL = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
with wS.Range("B" & nL)
.offset(0, -1).value = Split(f.Name, ".")(0)
.offset(0, 1).value = Left(FileDateTime(f.path), 10)
.rowheight = 30
with ws.shapes.addpicture(f.path, msofalse, msotrue, .left, .top, -1, -1)
.height = ws.rows(nL).rowheight
.name = f.path
maxwidth = application.max(maxwidth, .width)
end with
end with
Next f
wS.Range("B:B").columnwidth = maxwidthCdlt,
Bonjour,
J'ai une erreur de compilation, je suppose que je ne compile pas le code correctement.
Dois-je substituer le code ci-dessous par le votre ?
For Each f In fso.GetFolder(folder).Files
nomFic = Split(f.Name, ".")
nL = ActiveSheet.Cells(Columns.Count, 1).End(xlUp).Row + 1
wS.Range("A" & nL) = nomFic(0)
wS.Range("C" & nL) = Left(FileDateTime(folder & "\" & f.Name), 10)
fullName = folder & "\" & f.Name
Set cellule = wS.Range("B" & nL)
cellule.Select
Set p = wS.Pictures.Insert(fullName)
cellule.ColumnWidth = p.Width * 52 / 288 ' La valeur 52 est à ajuster
cellule.RowHeight = p.Height
Next f
wS.Columns("A").Columns.AutoFit
wS.Columns("C").Columns.AutoFit
End SubMerci d'avance.
Exactement. Il faut aussi déclarer la variable maxwidth (ou enlever l'Option Explicit).
Cdlt,
Sub Macro1()
Dim f As Object, fso As Object, p As Object
Dim h As Double, b As Double, g As Double, d As Double, maxwidth as double ' Haut, bas, gauche, droite
Dim folder As String, nomFic() As String, fullName As String, nL As Integer
Dim wS As Worksheet, cellule As Range
Set wS = ActiveSheet
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then MsgBox "Importation annulée.": wS.Cells.Clear: End
wS.Cells.Clear
Cells(1, 1) = "Fichier"
Cells(1, 2) = "Photo"
Cells(1, 3) = "Date"
folder = .SelectedItems(1)
End With
For Each f In fso.GetFolder(folder).Files
nL = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
with wS.Range("B" & nL)
.offset(0, -1).value = Split(f.Name, ".")(0)
.offset(0, 1).value = Left(FileDateTime(f.path), 10)
.rowheight = 30
with ws.shapes.addpicture(f.path, msofalse, msotrue, .left, .top, -1, -1)
.height = ws.rows(nL).rowheight
.name = f.path
maxwidth = application.max(maxwidth, .width)
end with
end with
Next f
wS.Range("B:B").columnwidth = maxwidth
End SubMerci, je n'avais pas enlevé l'Option Explicit.
Cela fonctionne bien et c'est ce que je voulais faire, cependant il ne prend en compte que les photos au format paysage et non celles au format portrait. C'est étrange non ?
Je viens de m’apercevoir que des photos se sont insérées dans des colonnes plus loin, bizarre.
Disons je voudrais un peu agrandir la taille des photos, est-ce possible ?
Re,
En effet, c'est super étrange de retrouver les images aussi loin !
Sub Macro1()
Dim f As Object, fso As Object, p As Object
Dim h As Double, b As Double, g As Double, d As Double, maxwidth as double ' Haut, bas, gauche, droite
Dim folder As String, nomFic() As String, fullName As String, nL As Integer
Dim wS As Worksheet, cellule As Range
Set wS = ActiveSheet
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then MsgBox "Importation annulée.": wS.Cells.Clear: End
wS.Cells.Clear
Cells(1, 1) = "Fichier"
Cells(1, 2) = "Photo"
Cells(1, 3) = "Date"
folder = .SelectedItems(1)
End With
For Each f In fso.GetFolder(folder).Files
nL = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
with wS.Range("B" & nL)
.offset(0, -1).value = Split(f.Name, ".")(0)
.offset(0, 1).value = Left(FileDateTime(f.path), 10)
.rowheight = 30
with ws.shapes.addpicture(f.path, msofalse, msotrue, .left, .top, -1, -1)
.lockaspectratio = msotrue
.height = ws.rows(nL).rowheight
.name = f.path
maxwidth = application.max(maxwidth, .width)
end with
end with
Next f
wS.Range("B:B").columnwidth = maxwidth
End SubPour augmenter la hauteur des images, il faut augmenter la valeur de .rowheight : mettre 45 ou 60 par exemple.
Cdlt,
Bonjour,
Merci. Toujours pareille, les photos au format portait s’éloigne. Je ne suis pas contre modifier le sens des colonnes. J'ai testé mais je n'ai pas réussi, j'ai du oublié quelque chose, car les photos se sont superposées.
Bonjour,
Pour l'instant, j'ai du mal à comprendre pourquoi les photos se retrouvent dans une autre colonne. Je vais faire quelques essais pour voir.
Sinon, pour remettre à zéro avant de recommencer la procédure, vous pouvez lancer cette macro qui efface toutes les formes :
sub ClearShapes()
for each sh in activesheet.shapes
sh.delete
next sh
end subCdlt,
Bonjour,
Je viens de tester et je n'ai pas ce problème de mon côté... Malheureusement, le seul ordi sur lequel je peux tester ne dispose pas de suffisamment d'images.
Voici un nouvel essai permettant d'avoir une largeur de colonne plus adaptée (enfin sur ma version) :
Sub Macro1()
Dim f As Object, fso As Object, p As Object
Dim h As Double, b As Double, g As Double, d As Double, maxwidth as double ' Haut, bas, gauche, droite
Dim folder As String, nomFic() As String, fullName As String, nL As Integer
Dim wS As Worksheet, cellule As Range
Set wS = ActiveSheet
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then MsgBox "Importation annulée.": wS.Cells.Clear: End
wS.Cells.Clear
Cells(1, 1) = "Fichier"
Cells(1, 2) = "Photo"
Cells(1, 3) = "Date"
folder = .SelectedItems(1)
End With
For Each f In fso.GetFolder(folder).Files
nL = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
with wS.Range("B" & nL)
.offset(0, -1).value = Split(f.Name, ".")(0)
.offset(0, 1).value = Left(FileDateTime(f.path), 10)
.rowheight = 30
with ws.shapes.addpicture(f.path, msofalse, msotrue, .left, .top, -1, -1)
.height = ws.rows(nL).rowheight
.name = f.path
maxwidth = application.max(maxwidth, .width * 24 / 131)
end with
end with
Next f
wS.Range("B:B").columnwidth = maxwidth
End SubCdlt,
Bonjour,
Merci, je viens de tester, j'avais au préalable mis toutes les photos au format paysage. Pour le test, il reste 5 photos sur 176 qui ne veulent pas s'insérer à la bonne place. J'ai vérifier, les photos ne sont pas plus lourdes que les autres. Si ce n'est qu'un faible nombre de photo, je peux les ajouter à la main.
J'ai voulu décaler les colonnes et les lignes pour laisser la 1ère colonne et la 1ère ligne de vide mais cela n'a pas fonctionné, je n''ai peut être pas changer toute les données.
Savez-vous s'il est possible qu'à la place de la date de modification du fichier, nous mettions la date de la prise de vue de la photo ? J'ai un peu cherché mais ce que j'ai essayé ne fonctionne pas.
Merci.
Bonjour,
Voici un essai adapté d'une solution de MFerrand :
Sub Macro1()
Dim f As Object, fso As Object, p As Object
Dim h As Double, b As Double, g As Double, d As Double, maxwidth as double ' Haut, bas, gauche, droite
Dim folder As String, nomFic() As String, fullName As String, nL As Integer
Dim wS As Worksheet, cellule As Range
Set wS = ActiveSheet
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then MsgBox "Importation annulée.": wS.Cells.Clear: End
wS.Cells.Clear
Cells(1, 1) = "Fichier"
Cells(1, 2) = "Photo"
Cells(1, 3) = "Date"
folder = .SelectedItems(1)
End With
For Each f In fso.GetFolder(folder).Files
nL = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
with wS.Range("B" & nL)
.offset(0, -1).value = Split(f.Name, ".")(0)
.offset(0, 1).value = Left(DatePriseVue(f.path), 10)
.rowheight = 30
with ws.shapes.addpicture(f.path, msofalse, msotrue, .left, .top, -1, -1)
.height = ws.rows(nL).rowheight
.name = f.path
maxwidth = application.max(maxwidth, .width * 24 / 131)
end with
end with
Next f
wS.Range("B:B").columnwidth = maxwidth
End Sub
Function DatePriseVue(FilePath As Variant)
'https://forum.excel-pratique.com/excel/importer-des-noms-de-photos-et-leur-date-de-prise-de-vue-t97464.html
dim t as variant, Filename as variant, Rep as variant
t = split(FilePath, "\"): Filename = t(ubound(t)): Rep = replace(FilePath, "\" & Filename, "")
With CreateObject("Shell.Application").Namespace(Rep)
DatePriseVue = .GetDetailsOf(.Items.Item(Filename), 12)
End With
End FunctionCdlt,
Bonjour,
Merci, c'est bien la date de prise de vue qui s'affiche, cependant pas complètement (voir ci-dessous), ou peut-on modifier ce problème, je ne vois pas dans le code ?
Toujours encore quelque photos qui ne s'insèrent pas, mais tant pis, je vais les insérer à la main, je n'arrive pas à savoir la cause, j'ai essayé de trouver, mais hormis un problème de format, je ne vois pas.
