Récupérer la date de création d'une image sous VBA
Bonjour,
je suis nouveau sur le forum et sous VBA.
Je me suis lancé dans un projet pour une tablette professionnel Windows 7.
Le projet est composé de deux étapes majeurs.
1/ L'opérateur s'identifie dans Userform1. Si Nom et Matricule OK alors Userform2 se lance.
2/ L'opérateur fait des sélections dans 8 combobox. Une fois le formulaire remplie, il y a un bouton qui devient utilisable sur cet Userform1.Le Bouton doit lancer l'APN de la tablette. (Jusque là tout fonctionne correctement).
J'aimerai récupérer ensuite dans un tableau feuil3
- Les données ComboBox sont bien récupérées au bon endroit.
- un lien hypertexte de la dernière image crée en colonne I.
- La date de création de cette image en colonne J.
Pour l'instant j'ai ça :
- j'ai tout les noms d'image du répertoire alors que je veux seulement la dernière.
- Le nom doit être un lien hypertexte.
- j'ai une date mais au format MM/JJ/AA. J'aimerai JJ/MM/AA
- le tout n'est pas au bon endroit (Lien hypertexte doit être en colonne I et Date en colonne J)
avec ce code
Option Explicit
Option Base 1
Sub triDecroissant_Fichiers_DateDreation()
Dim Fichier As String, Chemin As String
'
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
Dim Fso As Object
Dim feuil3()
Dim m As Integer, i As Integer
Dim z As Byte, Valeur As Byte
Dim Cible As Variant
Dim FileItem As Object
'---liste les fichiers du répertoire ---
Chemin = "\\fichier-lh\users\n0563556\Documents\Mes fichiers reçus"
Fichier = Dir(Chemin & "\*.jpg")
'pour filtrer sur un type de fichiers (par exemple xls)
'Fichier = Dir(Chemin & "\*.xls")
'Boucle sur les fichiers
Do
m = m + 1
ReDim Preserve feuil3(2, m)
feuil3(1, m) = Fichier
Set Fso = CreateObject("Scripting.FileSystemObject")
Set FileItem = Fso.GetFile(Chemin & "\" & Fichier)
'Récupère la date de création
feuil3(2, m) = Left(FileItem.DateCreated, 10)
'10 = le nombre de caractère date à afficher dans tableau
'Pour récupérer la date de dernière modification
'Tableau(2, m) = Left(FileItem.DateLastModified, 10)
'Pour récupérer la taille du fichier
'Tableau(2, m) = Left(FileItem.Size, 10)
Fichier = Dir
Loop Until Fichier = ""
'---Trie les fichiers par ordre décroissant de création ---
Do
Valeur = 0
For i = 1 To m - 1
If CDate(feuil3(2, i)) < CDate(feuil3(2, i + 1)) Then
For z = 1 To 2
Cible = feuil3(z, i)
feuil3(z, i) = feuil3(z, i + 1)
feuil3(z, i + 1) = Cible
Next z
Valeur = 1
End If
Next i
Loop While Valeur = 1
'--- Transfère les données dans la feuille de calcul ---
For i = 1 To m
Cells(i, 1) = feuil3(1, i)
Cells(i, 2) = feuil3(2, i)
Next i
End Subj'aimerai ça :
Pouvez-vous m'aider s'il vous plait ?
Cordialement,
bonjour,
une proposition à tester
Option Explicit
Option Base 1
Sub dernierfichier()
Dim Fichier As String, Chemin As String
'
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
Dim Fso As Object
Dim feuil3(2, 1)
Dim m As Integer, i As Integer
Dim z As Byte, Valeur As Byte
Dim Cible As Variant
Dim FileItem As Object
'---liste les fichiers du répertoire ---
Chemin = "\\fichier-lh\users\n0563556\Documents\Mes fichiers reçus"
Fichier = Dir(Chemin & "\*.jpg")
'pour filtrer sur un type de fichiers (par exemple xls)
'Fichier = Dir(Chemin & "\*.xls")
'Boucle sur les fichiers
Set Fso = CreateObject("Scripting.FileSystemObject")
Do
Set FileItem = Fso.GetFile(Chemin & "\" & Fichier)
'Récupère la date de création et mémorise nom de fichier ayant date la plus récente
If FileItem.datecreated > feuil3(2, 1) Then feuil3(2, 1) = FileItem.datecreated: feuil3(1, 1) = Fichier
Fichier = Dir
Loop Until Fichier = ""
'--- Transfère les données dans la feuille de calcul ---
ActiveSheet.Hyperlinks.Add Anchor:=Cells(2, 9), Address:=feuil3(1, 1), TextToDisplay:=feuil3(1, 1)
Cells(2, 10) = Format(feuil3(2, 1), "dd/mm/yy")
End SubBonjour h2so4,
Merci de ton aide.
Je viens de tester.
Ce qui fonctionne
- J'ai un lien hypertexte qui se crée de la dernière image du répertoire en colonne I.
- J'ai bien la date en colonne J
Ce qui ne fonctionne pas
- aucun lien quand je lance l'application depuis le début mais fonctionne quand je lance l'appli depuis le userform3
- Le lien Hypertexte " impossible d'ouvrir le fichier spécifié"
re-bonjour,
pour ton deuxième point qui ne fonctionne pas, j'ai oublié de mettre le chemin dans le lien. voici une correction.
Option Explicit
Option Base 1
Sub dernierfichier()
Dim Fichier As String, Chemin As String
'
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
Dim Fso As Object
Dim feuil3(2, 1)
Dim m As Integer, i As Integer
Dim z As Byte, Valeur As Byte
Dim Cible As Variant
Dim FileItem As Object
'---liste les fichiers du répertoire ---
Chemin = "\\fichier-lh\users\n0563556\Documents\Mes fichiers reçus"
Fichier = Dir(Chemin & "\*.jpg")
'pour filtrer sur un type de fichiers (par exemple xls)
'Fichier = Dir(Chemin & "\*.xls")
'Boucle sur les fichiers
Set Fso = CreateObject("Scripting.FileSystemObject")
Do
Set FileItem = Fso.GetFile(Chemin & "\" & Fichier)
'Récupère la date de création et mémorise nom de fichier ayant date la plus récente
If FileItem.datecreated > feuil3(2, 1) Then feuil3(2, 1) = FileItem.datecreated: feuil3(1, 1) = Fichier
Fichier = Dir
Loop Until Fichier = ""
'--- Transfère les données dans la feuille de calcul ---
ActiveSheet.Hyperlinks.Add Anchor:=Cells(2, 9), Address:=chemin & "\" & feuil3(1, 1), TextToDisplay:=feuil3(1, 1)
Cells(2, 10) = feuil3(2, 1)
cells(2,10).numberformat="DD/MM/YY"
End Sub
Par contre la date est encore à l'anglaise 07/05/2016
Par contre le lien ne s'ouvre toujours pas ( j'ai une piste)
L'ensemble ne se lance pas quand fait un test.
Max1991 a écrit :Par contre le lien ne s'ouvre toujours pas ( j'ai une piste)
il manquait un "\" dans le lien, corrigé dans le message précédent.
Merci le lien s'ouvre correctement !
En revanche l'ensemble de fonctionne pas quand je fais le test depuis le début.
Cette partie du code est dans module2
je pense que le programme n'appelle pas le module du coup il ne se passe rien.
Cela fonctionne seulement quand je suis dans le module, que j'enregistre puis je fais play.
Je vais essayer de trouver une solution pour appeler le module dans mon before close.
Le lien hypertexte écrase la ligne précédente au lieu de s'ajouter à la case vide suivante
re-bonjour,
Option Explicit
Option Base 1
Sub dernierfichier()
Dim Fichier As String, Chemin As String
'
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
Dim Fso As Object
Dim feuil3(2, 1)
Dim m As Integer, i As Integer
Dim z As Byte, Valeur As Byte
Dim Cible As Variant
Dim FileItem As Object
'---liste les fichiers du répertoire ---
Chemin = "\\fichier-lh\users\n0563556\Documents\Mes fichiers reçus"
Fichier = Dir(Chemin & "\*.jpg")
'pour filtrer sur un type de fichiers (par exemple xls)
'Fichier = Dir(Chemin & "\*.xls")
'Boucle sur les fichiers
Set Fso = CreateObject("Scripting.FileSystemObject")
Do
Set FileItem = Fso.GetFile(Chemin & "\" & Fichier)
'Récupère la date de création et mémorise nom de fichier ayant date la plus récente
If FileItem.datecreated > feuil3(2, 1) Then feuil3(2, 1) = FileItem.datecreated: feuil3(1, 1) = Fichier
Fichier = Dir
Loop Until Fichier = ""
'--- Transfère les données dans la feuille de calcul ---
i = Cells(Rows.Count, 9).End(xlUp).Row + 1
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 9), Address:=Chemin & "\" & feuil3(1, 1), TextToDisplay:=feuil3(1, 1)
Cells(i, 10) = feuil3(2, 1)
Cells(i, 10).NumberFormat = "DD/MM/YY"
End SubJe ne suis pas certain que cela fonctionne. Tu sais comment executer le module2 à partir de mon userform3 ?
je ne suis pas un voyant extra lucide. je ne peux pas te donner un avis sur un code que tu ne fournis pas.
Excuse moi pour mon imprécision.
Quand je disais je ne pense pas que cela fonctionne, c'est une vérité ça ne fonctionne pas. Je ne sais simplement pas si ça vient du code en question où du fait qu'il soit dans module2.
Module 2 =
Option Explicit
Option Base 1
Sub dernierfichier()
Dim Fichier As String, Chemin As String
'
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
Dim Fso As Object
Dim feuil3(2, 1)
Dim m As Integer, i As Integer
Dim z As Byte, Valeur As Byte
Dim Cible As Variant
Dim FileItem As Object
'---liste les fichiers du répertoire ---
Chemin = "\\fichier-lh\users\n0563556\Documents\Mes fichiers reçus"
Fichier = Dir(Chemin & "\*.jpg")
'pour filtrer sur un type de fichiers (par exemple xls)
'Fichier = Dir(Chemin & "\*.xls")
'Boucle sur les fichiers
Set Fso = CreateObject("Scripting.FileSystemObject")
Do
Set FileItem = Fso.GetFile(Chemin & "\" & Fichier)
'Récupère la date de création et mémorise nom de fichier ayant date la plus récente
If FileItem.datecreated > feuil3(2, 1) Then feuil3(2, 1) = FileItem.datecreated: feuil3(1, 1) = Fichier
Fichier = Dir
Loop Until Fichier = ""
'--- Transfère les données dans la feuille de calcul ---
i = Cells(Rows.Count, 9).End(xlUp).Row
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 9), Address:=Chemin & "\" & feuil3(1, 1), TextToDisplay:=feuil3(1, 1)
Cells(i, 10) = feuil3(2, 1)
Cells(i, 10).NumberFormat = "DD/MM/YY"
End Subj'aimerai que ce code s’exécute entre la sauvegarde et la fermeture ci-dessous :
Private Sub CommandButton1_Click()
ThisWorkbook.Save
ThisWorkbook.Close
End Sub
Private Sub CommandButton2_Click()
Quitter.Hide
Remplir.Show
End Sub
Private Sub Frame1_Click()
End Sub
Private Sub UserForm_Click()
End Subd'où ma question, doit-on appeler un module pour qu'il s’exécute à un moment précis?
re-bonjour,
si tu ne demandes pas d'exécuter une macro, elle ne s'exécutera pas.
mets
dernierfichier entre les deux instructions. mais sache que le résultat de la macro ne se retrouvera pas dans le fichier lorsque tu le rouvriras.
en effet
tu sauves
tu executes la macro qui fait des changements
tu fermes sans sauver les changements
ce qui à mon avis n'est pas ce que tu souhaites.
J'ai fait exactement ce que tu m'as écrit.
j'obtiens cela :
J'ai fait exactement ce que tu m'as écrit.
et moi je t'ai donné les instructions pour faire ce que tu as demandé.
et je t'ai dit que cela ne sauverait pas les modifications dans ton fichier et donc que ces modifications ne seront pas présentes lorsque tu rouvriras ton fichier.
j'ai donc un doute quant au placement de cette instruction entre l'instruction save et l'instruction close.
Bonjour,
J'ai appelé la macro avant le save.
J'ai ajouté des +1 à I pour le décalage.
i = Cells(Rows.Count, 9).End(xlUp).Row
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i+1, 9), Address:=Chemin & "\" & feuil3(1, 1), TextToDisplay:=feuil3(1, 1)
Cells(i+1, 10) = feuil3(2, 1)
Cells(i+1, 10).NumberFormat = "DD/MM/YY"Je ferme et j'enregistre et ça fonctionne !!!! j'ai bien la saut de ligne à chaque fois.
Je suis super content ! et quand je suis content je vomis (LCDLP)
Un grand merci à toi pour ta patience et ton aide !