Gestion de fichiers de cours

**GADENSEB** · 03/06/2016, 15h31

Hello Le Forum,
J'ai besoin d'un avis / aide sur ce projet :

Le but est de créer une Bdd des fichiers présents dans le dossier "Dossier 1"
Chaque fichier (word, excel, photo....) sera cliquable avec un lien hypertexte

Les fichiers ne seront jamais bougés dans les dossiers
Le but du jeu étant d'affecter des "Théme à chaque fichier",un ou plusieurs, comme au dessus.
Les choix de thèmes par fichier restants en permanence et pouvant etre modifier

Pour ce faire :

- Recherche Récursive Sur le Dossier 1 à chaque ouverture de fichier
ou à lancer par le biais d'une macro
- Les fichiers déjà inscrits ne doivent pas être réinscrits
- les nouveaux fichiers doivent apparaître en tête de liste, en jaune

Je ne demande pas un code en entier mais juste qq axes de réflexion.

Est-ce jouable?
Existe-t-il des fichiers similaires? (j'ai pas trouvé grand chose)

Merci

**parmi** · 03/06/2016, 16h40

Bonjour,

Le Dossier 1 en question contient des sous-dossiers ?
Combien de fichiers peut-il y avoir en tout ? parce que tout lire à chaque ouverture pourrait devenir un peu long, si ce n'est pas vraiment nécessaire...

**GADENSEB** · 03/06/2016, 16h45

Oui effectivement j'aurais du le préciser ....sorry

Il ya des sous-dossiers et des sous-sous dossiers ......
Environ 1500 fichiers...
C'est une base qui vit (grossie) en permanence ...

du coup, mes 2 explications sont claires ?
LOL

Bonne am

**parmi** · 03/06/2016, 17h23

Est-ce que certains fichiers peuvent avoir le même nom ?
Si je comprends bien, tu veux le nom du fichier en A et le chemin seulement en B, c'et bien ça ?

**GADENSEB** · 04/06/2016, 08h27

Hello.
Oui certains fichiers peuvent avoir le mm nom malheureusement.
Oui a nom du fichier en colonne A et chemin en colonne b
:-)

**parmi** · 06/06/2016, 16h29

Tu peux essayer ceci.
La première fois, toutes les lignes seront jaunes puisque fichiers non existants, en principe...
À adapter

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
68
69
70
71
72
73
74
75
76
77
78
Sub Debut()
    Dim objShell As Object, objFolder As Object, oFolderItem As Object
    Dim Chemin As String
 
    'Demande le dossier à rechercher
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
    Set oFolderItem = objFolder.Items.Item
    Chemin = oFolderItem.Path & "\"
 
    ListerFichiers Chemin
 
    MsgBox "Terminé"
End Sub
 
'Fonction récursive de recherche
Private Sub ListerFichiers(Chemin As Variant)
    Dim Fichier As Variant
    Dim Liste As Collection
 
    On Error GoTo Erreur
 
    If GetAttr(Chemin) = vbDirectory Then
        If Right(Chemin, 1) <> "\" Then
            Chemin = Chemin & "\"
        End If
    End If
 
    Set Liste = New Collection
    Fichier = Dir(Chemin & "*.*", vbDirectory + vbHidden + vbSystem)
 
    While Fichier > ""
        If GetAttr(Chemin & Fichier) = vbDirectory Then
            If Left(Fichier, 1) <> "." Then
                Liste.Add Chemin & Fichier
            End If
        ElseIf GetAttr(Chemin & Fichier) = vbArchive Then
            If Not Present(Chemin, Fichier) Then
                Rows(2).Insert
                Range("A2") = Fichier
                Range("B2") = Chemin
                Range("A2").Hyperlinks.Add _
                    Anchor:=Range("A2"), _
                    Address:=Replace(Chemin & Fichier, " ", "%20")
                Range("A2:G2").Interior.Color = vbYellow
            End If
        End If
 
        Fichier = Dir
 
        DoEvents
    Wend
 
    For Each Fichier In Liste
        ListerFichiers Fichier
        DoEvents
    Next
 
    Set Liste = Nothing
 
    Exit Sub
Erreur:
    MsgBox Err.Number & vbCrLf & Err.Description
    Stop    'Pour déboguage > F8+F8 lors de l'arrêt
    Resume
End Sub
 
Function Present(Chemin As Variant, Fichier As Variant) As Boolean
    Dim I As Long, nbLignes As Long
 
    nbLignes = Cells(Rows.Count, "A").End(xlUp).Row
    For I = 2 To nbLignes
        If Range("A" & I) = Fichier And Range("B" & I) = Chemin Then
            Present = True
            Exit Function
        End If
    Next
End Function

**GADENSEB** · 07/06/2016, 11h34

Hello
Parfait ton code.
C'est ce que je cherchais.

par contre :
- si un fichier est modifié (pas le nom du fichier) ? : est-il considéré comme nouveau ou "ancien" ?
- Si un fichier est supprimer : apparement il n'est pas supprimer de la liste; peut-on faire en sorte qu'il soit supprimer de la liste ?
- petite amélioration, pourrait-on supprimer les jaune si au moins une des colonnes C à G (ou plus) est remplie ?

Merci à toi

**parmi** · 07/06/2016, 12h06

Si tu regardes le code, il n'y a aucune vérification de la date de modification, donc ça passe inaperçu.
Seuls les noms et répertoires sont vérifiés.

Pour la suppression des fichiers, il faudrait faire une autre macro pour faire cette vérification.

Pour la suppression des jaunes, il suffit d'utiliser Worksheet_Change()
Ça devrait être assez simple...

**GADENSEB** · 07/06/2016, 12h09

Bien Vu !

Je m'en occupe !!
Thanks

**GADENSEB** · 25/08/2016, 09h49

Bonjour Parmi, le Forum
Je reviens avec mon fichier après qq temps.

Le fondamental du fichier n'a pas changé
Mais je rajoute une fonction :
- Quand je saisie qqc dans l'une ou plusieurs colonne C à G, la ligne entière (A:G) devient blanche.
- Par contre quand j'enléve (colonne C à G) et qu'il n'y a plus rien dans ces colonnes, la ligne entière (A:G) redevient jaune.....

Cela me pose des soucis à l'mport ......

QQn aurait une idée ?

Merkii

**kiki29** · 25/08/2016, 11h45

Salut, voir Liste des fichiers d'un dossier + Liens

Liste des fichiers d'un dossier avec recherche récursive ou non via les APIs
Possibilité de créer des liens hypertextes vers les fichiers listés

A adapter à ton contexte

Invité · 25/08/2016, 13h05

Bonjour,
J'interviens pas forcément trop tard, car pour la suppression des fichiers, tu peux placer. Le texte de toutes tes linges a rouge comme pour le fond jaune.

Si un fichier existe dans un répertoire tu le repasses à normal donc tout ce qui reste rouge est supprimer et tu agis en conséquence!

**GADENSEB** · 31/08/2016, 10h20

Hello, Kiki29, Rudpt, Le forum
Je re sur ce sujet.

Merci des conseils, j'essaye de me dépatouiller, mais je rame

Mon fichier bug à l'analyse des fichiers car
Nom : Capture.PNG
Affichages : 266
Taille : 8,5 Ko

Nom : Capture.PNG
Affichages : 266
Taille : 8,5 Ko

Est-ce qqn, pourrait m'aider, svp je rame

Merci à vous

Bonne journée

Invité · 31/08/2016, 11h59

Bonjour,
2 chose!

1) le target ne concerne pas forcément une cellule unitaire mais un range("? : ?")! toutes les cellules concernées par le change font parties du Target.

Code :

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

range("A1:A123").value="TOTO"

dans ce cas

Code :

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

for i=1 to target.rows.count

2) si la valeur d'une cellule est null alors Err!

Code :

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

if trim("" & target)="" then

**GADENSEB** · 02/09/2016, 09h26

Hello

Merci des infos

J'ai fait un

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
Private Sub Worksheet_Change(ByVal Target As Range)
 
    If Not Intersect(Target, Range("C2:G5000")) Is Nothing Then
For I = 1 To Target.Rows.Count
 
    If Target = "" Then
      'Target.Row.Interior.Color = vbYellow
       Target.EntireRow.Interior.Color = vbYellow
       Else
       Target.Interior.Color = vbWhite
     End If
 
Next I
End If
End Sub

Mais j'ai une incomparabilité de type 13 ????

L'ordre des IF n'est pas bon?

Invité · 02/09/2016, 09h41

Bonjour,

Code :

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

1
2
3
4
5
6
For I = 1 To Target.Rows.Count
 
    If trim("" & Target(I,1)) = "" Then
 Else
       Target.Interior.Color = vbWhite
     End If

**GADENSEB** · 02/09/2016, 14h46

parfait, j'ai juste un peu modifié avec un next I

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Private Sub Worksheet_Change(ByVal Target As Range)
 
 
For I = 1 To Target.Rows.Count
 
    If Trim("" & Target(I, 1)) = "" Then
 Else
       Target.Interior.Color = vbWhite
     End If
 Next I
 
End Sub

du coup, next step, lol :
Je souhaite :
- Si une des colonnes (C:G) est remplie dans au moins une des cases, toute la ligne (A:G)passe en blanc
- Si plus aucune des colonnes(C:G) n'est remplie --> toute la ligne passe en jaune

j'ai toujours du mal avec les selections de colonnes.... snifff

Bonne journée
Seb

Invité · 02/09/2016, 15h07

Code :

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

1
2
3
4
5
6
7
For I = 1 To Target.Rows.Count
     t=""
    for c=3 to 7  ' 3= c; 7 = G
         t=t &  Trim("" & Target(I, c)) 
    next
    If t <> "" Then  EntireRow  Target(I, 1).EntireRow.Interior.Color = vbWhite else Target(I, 1).EntireRow.Interior.Color = vbYellow
 Next I

**GADENSEB** · 29/08/2017, 01h50

hello
je reviens sur ce projet un peu mis de coté
le premier code est super

pour rappel je voudrais lister les fichiers d'un répertoire bien précis pour attribuer à chacun une "catégorie) dans excel
à chaque scan du dossier (pour voir les nouveaux) les "catégories" précédemment noté ne sont pas supprimées

après réflexion (et de nombreuses lecture sur le net) je me dis que passer par les attributs de fichiers (commentaires ou mots clefs) serait la bonne solution.
je nomme la variable commentaire pour la placer en colonne C

apparemment la méthode DSO (vu sur DEVELOPPEZ) serait la bonne solution

du coup je tente le coup mais j'ai un message d'erreur sur Dim DSO As DSOFile.OleDocumentProperties
Nom : Capture.PNG
Affichages : 220
Taille : 7,1 Ko

Nom : Capture.PNG
Affichages : 220
Taille : 7,1 Ko

qqn aurait une idée ?

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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
Sub Debut()
    'Dim objShell As Object, objFolder As Object, oFolderItem As Object
    Dim Chemin As String
 
    'Demande le dossier à rechercher
   Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
    Set oFolderItem = objFolder.Items.Item
   Chemin = oFolderItem.Path & "\"
 
   ' Chemin = "T:\Images" & "\"
    ListerFichiers Chemin
 
    MsgBox "Terminé"
End Sub
 
'Fonction récursive de recherche
Private Sub ListerFichiers(Chemin As Variant)
    Dim Fichier As Variant
    Dim Liste As Collection
    Dim commentaire As Long
 
     Dim DSO As DSOFile.OleDocumentProperties
 
    Set DSO = New DSOFile.OleDocumentProperties
 
 
 
    On Error GoTo Erreur
 
    If GetAttr(Chemin) = vbDirectory Then
        If Right(Chemin, 1) <> "\" Then
            Chemin = Chemin & "\"
        End If
    End If
 
 
 
    Set Liste = New Collection
    Fichier = Dir(Chemin & "*.*", vbDirectory + vbHidden + vbSystem)
    DSO.Open sfilename:=Fichier
 
 
    commentaire = DSO.SummaryProperties.Comments
 
 
 
    While Fichier > ""
        If GetAttr(Chemin & Fichier) = vbDirectory Then
            If Left(Fichier, 1) <> "." Then
                Liste.Add Chemin & Fichier
            End If
        ElseIf GetAttr(Chemin & Fichier & commentaire) = vbArchive Then
            If Not Present(Chemin, Fichier, commentaire) Then
                Rows(2).Insert
                Range("A2") = Fichier
                Range("B2") = Chemin
                Range("c2") = commentaire
                Range("A2").Hyperlinks.Add _
                    Anchor:=Range("A2"), _
                    Address:=Replace(Chemin & Fichier, " ", "%20")
                Range("A2:K2").Interior.Color = vbWhite
            End If
        End If
 
        Fichier = Dir
 
        DoEvents
    Wend
 
    For Each Fichier In Liste
        ListerFichiers Fichier
        DoEvents
    Next
 
    Set Liste = Nothing
 
    Exit Sub
Erreur:
    MsgBox Err.Number & vbCrLf & Err.Description
    Stop    'Pour déboguage > F8+F8 lors de l'arrêt
    Resume
End Sub
 
Function Present(Chemin As Variant, Fichier As Variant) As Boolean
    Dim I As Long, nbLignes As Long
 
    nbLignes = Cells(Rows.Count, "A").End(xlUp).Row
    For I = 2 To nbLignes
        If Range("A" & I) = Fichier And Range("B" & I) = Chemin Then
            Present = True
            Exit Function
        End If
    Next
End Function

Gestion de fichiers de cours [XL-2013]

Macros et VBA Excel

Discussions similaires

Partager

Partager