Créer un lien hypertexte à partir de l'image la plus récente d'un dossier

**Max1991** · 04/07/2016, 16h57

Bonjour Marc L,

j'aimerai que pour le code ci dessous, les données tombent en colonne I pour le lien photo et J pour la date.
J'ai déjà des données en A et B.

Merci de votre aide

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
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
 
 
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 Scripting.FileSystemObject
    Dim FileItem As Scripting.File
    Dim Feuil3()
    Dim m As Integer, i As Integer
    Dim z As Byte, Valeur As Byte
    Dim Cible As Variant
 
    '---liste les fichiers du répertoire ---
    Chemin = "\\fichier-lh\users\n0563556\Documents\Mes fichiers reçus\"
    Fichier = Dir(Chemin & "\*.*")
    '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)
        '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

**kiki29** · 04/07/2016, 17h23

Salut,

**Max1991** · 05/07/2016, 08h52

Bonjour,

au titre de paraître stupide je ne sais pas où mettre ce morceau de code ni comment le modifier pour que ça fonctionne. Je suis Novice en VBA excusez-moi encore.

**kiki29** · 05/07/2016, 12h04

Salut, allons quand même ....

Dans :

For i = 1 To m
Cells(i, 1) = .....
Cells(i, 2) = .....
Next i

1 et 2 [ColumnIndex] de Cells(i, xyz) sont à remplacer par les colonnes désirées sachant que A = colonne 1, B colonne 2, I colonne ... etc

**Max1991** · 05/07/2016, 14h35

Merci.

j'ai essayé ça. J'ai mis le code dans Module2 mais je pense qu'il n'ai pas appelé lorsque je test. ça fonctionne parfaitement que quand j'enregistre et je fais play à partir du module2

Comment appeler module2 à s'executer dans mon Userform3/ before_close entre enregistrer et quitter ?

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
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
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

**Max1991** · 06/07/2016, 10h03

La solution était la suivante :

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
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
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\H0985683\Documents\Mes fichiers reçus"
    Fichier = Dir(Chemin & "\*.jpg")
    'pour filtrer sur un type de fichiers (par exemple jpg)
  'Fichier = Dir(Chemin & "\*.jpg")
 
    '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 la 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+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"
 
End Sub

Un grand merci pour votre aide et votre patience.

Cordialement,

Créer un lien hypertexte à partir de l'image la plus récente d'un dossier [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager