Discussion :

[mihego32]

Salut à tous les forumeurs,

Vous m'écrirez sans doute qu'il existre des freewares qui fournissent la liste des unités, des dossiers d'une unité et des fichiers d'un dossier comme DirLister ou Directory List & Print pour n'en citer que 2. Mais le premier ne donne rien d'utile (uniquement le répertoire principal sans filtre !) tant qu'une $licence n'est pas achetée (et ce n'est pas très correct de demander de payer une licence pour un programme que la programmeuse d'origine distribuait vraiment gratuitement avant de décéder). Et le second n'offre pas non plus de filtres et sa sortie est limitée à l'imprimante ou au presse-papier avec une fenêtre dont le contenu est inaccessible. De la m... AMHA. Et je n'ai encore rien trouvé d'autre comme freeware gratuit partageable qui corresponde à mes demandes.

Dès lors, pour un usage d'abord personnel et particulier et pour rester en bonne forme en programmation, j'ai voulu développer une petite base msAccess 2010 (sous Win10 Pro 64 bits) pour offrir une solution fonctionnelle, que je compte d'ailleurs mettre à la disposition des sites sympathiques dont les utilisateurs m'ont apporté par leurs pages des informations très utiles. Qu'ils en soient remerciés.

J'utilise FileSystemObject, l'usage de Dir ne donnant pas les mêmes possibilités. En parcourant la liste des dossiers d'une unité, disons D:, j'ai eu des soucis avec D:\$RECYCLE.BIN et D:\System Volume Information : facilement ignorables avec un test sur ces 2 noms. Mais je passe aussi sur des dossiers cachés comme D:\Internet\Profiles\.BackupManager, dossiers qui sont considérés comme inexistants avec le code suivant If Dir(strDosDépart, vbDirectory) = "" Then (avec strDosDépart contenant le nom complet).

Je me suis mis à la recherche d'une méthode permettant de filtrer les dossiers de ce genre là, mais sans devoir coder en dur leurs noms, car tous les dossiers cachés ne sont pas prévisibles. J'ai trouvé ces codes des dossiers à problèmes (pour moi !) : les 2 premiers cités avec 22, le suivant avec 18 et D:\Mes sources de données avec 20 tandis que les dossiers apparemment standards pouvaient avoir des codes de 16 (le plus fréquent) ou 17, voire 48 (?). Sur cette base je filtre les dossiers à retenir :

Code :

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

1
2
3
4
    Set oFldSource = oFSO.GetFolder(strDosDépart)
    For Each oFld In oFldSource.SubFolders          ' Parcourt les Répertoires
        bAttr = oFld.Attributes
        If bAttr <> 18 And bAttr <> 20 And bAttr <> 22 Then

Dans la perspective d'avoir d'autres dossiers avec des valeurs inattendues, je me demande comment décoder ces valeurs et ce qu'elles signifient (et cela n'a rien à voir avec la liste ... objFolder.GetDetailsOf(strFilename, I). J'ai bien cherché sur l'Internet en Français et Anglais mais en vain. Donc bienvenue à vos réponses...

[loufab]

Bonjour Michel,

En effet il n'y a pas de petits profits. Exploiter le code d'une personne décédé et le vendre, c'est vraiment à c...

Concernant les attributs du FSO, il faut voir directement chez MS.

MSDN ou Technet :

Ici tu as le point d'entrée du modèle FSO :

https://technet.microsoft.com/en-us/.../ee198742.aspx

Normalement les enums y sont tous.

Cordialement,

[mihego32]

Merci Loufab pour cette réponse et l'information sur ce site.
J'y suis allé et sous Enumerating Folder Properties, référant à Microsoft® Windows® 2000 Scripting Guide, j'ai trouvé les propriétés comme :

Code :

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

1
2
3
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\FSO")
Wscript.Echo "Date created: " & objFolder.DateCreated

Mais je n'y ai rien trouvé à propos de ces codes d'attributs qui servent sans doute à indiquer le type de dossier...
Je continue à chercher et je vais traduire ma question pour la poser sur ce forum Technet, du moins quand j'aurai trouvé la page dédiée à msAccess 2010.

Bon week-end.

Retour d'info : recherches faites sur TechNet (Fr/En) avec le titre de ce post ou FileSystemObject ou Access 2010 attributs d'un objet Dossier (Folder) et les réponses étaient limitées à Importation et exportation en bloc avec Active Directory ou Exchange Server‎ : chou blanc.

[Invité]

bonjour,

ici nous avons un énumeateur bit à bit de chaque argument et nous devons reconstituer un mot de 8 bits!

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
Enum Attr
Normal = 0       'Normal file. No attributes are set. (bit 0) ou plus exactement mot(attributs=0)
ReadOnly = 1     'Read-only file. Attribute is read/write.  (bit 1)
Hidden = 2       'Hidden file. Attribute is read/write. (bit 2)
System = 4       'System file. Attribute is read/write   (bit 3)
Volume = 8       'Disk drive volume label. Attribute is read-only.  (bit 4)
Directory = 16   'Folder or directory. Attribute is read-only. (bit 5)
Archive = 32     'File has changed since last backup. Attribute is read/write. (bit 6)
Alias = 64       '  Link or shortcut. Attribute is read-only. (bit 7)
Compressed = 128   (bit 8)
 
Sub test()
' If bAttr <> 18 And bAttr <> 20 And bAttr <> 22 Then
  If bAttr <> (Directory + Hidden) And bAttr <> (Directory + System) And bAttr <> (Directory + System + Hidden) Then
if  bAttr and Directory  =Directory then msgbox "Directory"
End Sub

Code JE NE TESTE QUE LES ARGUMENT QUE JE VEUX :

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

 If CBool(bAttr And Directory) * CBool(bAttr And System) Or CBool(bAttr And Directory) * CBool(bAttr And Hidden) Then MsgBox ""

Code :

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

1
2
bAttr = 20  
If CBool(bAttr And Directory) And (CBool(bAttr And System) Or CBool(bAttr And Hidden)) Then MsgBox ""

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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
'Permet de vérifier si le répertoire dont le nom est précisé en paramètre (Repertoires) existe. Retourne True s'il existe, sinon FalsePublic Function Repertoires_Existe(Repertoires)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Repertoires_Existe = fso.FolderExists(Repertoires)
Set fso = Nothing
End Function
'Taille d'un répertoire
Public Function Taille_Repertoire(Repertoire)
Dim fso
Dim Rep
Set fso = CreateObject("Scripting.FileSystemObject")
    Set Rep = fso.GetFolder(Repertoire)
    Taille_Repertoire = Rep.Size
End Function
Function Repertoire_Date_Creation(Repertoire)
  Dim fso
Dim Rep
Set fso = CreateObject("Scripting.FileSystemObject")
    Set Rep = fso.GetFolder(Repertoire)
    Repertoire_Date_Creation = Rep.DateCreated
End Function
'Crée un répertoire, dont l'emplacement et le nom sont précisé par le chemin d'accès complet précisé en argument (NewRepertoires).
Public Sub Creer_Repertoires(NewRepertoires)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim t
Dim R
Dim I
R = ""
t = Split(NewRepertoires & "\", "\")
For I = 0 To UBound(t) - 1
    If Trim("" & t(I)) <> "" Then
        R = R & Trim("" & t(I))
        If Repertoires_Existe(R) = False Then fso.CreateFolder "" & R
    End If
     R = R & "\"
Next
Set fso = Nothing
End Sub
'Copie un répertoire, ainsi que tous les fichiers et sous-répertoires qu'il contient, d'une source vers une destination.
Public Sub Copie_Repertoires(Source, Destination)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFolder Source, Destination, True
Set fso = Nothing
End Sub
'Déplace un ou plusieurs répertoire d'un emplacement source vers une destination.
Public Function Deplace_Repertoire(Source, Destination)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fso.MoveFolder Source, Destination
If Err > 0 Then Deplace_Repertoire = Err.Description
Err.Clear
On Error GoTo 0
Set fso = Nothing
End Function
'Permet de supprimer un répertoire et tous les fichiers et sous-répertoires qu'il contient.
Public Sub Supprimer_Repertoire(DelRepertoire)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFolder DelRepertoire, True
Set fso = Nothing
End Sub
'Taille d'un répertoire
Public Function Taille_Fichier(Fichier)
Dim fso
Dim Fich
Set fso = CreateObject("Scripting.FileSystemObject")
Set Fich = fso.GetFile(Fichier)
    Taille_Fichier = Fich.Size
End Function
'Vérifie lexistance d'un   fichier
Public Function Fichier_Exist(Fichier)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Fichier_Exist = fso.FileExists(Fichier)
Set fso = Nothing
End Function
'Retourne le nom du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_Name(Fichier)
Dim fso
If Fichier_Exist(Fichier) = True Then
Set fso = CreateObject("Scripting.FileSystemObject")
Fichier_Name = fso.GetBaseName(Fichier)
Set fso = Nothing
End If
End Function
'Retourne l'extension du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_extension(Fichier)
Dim fso
If Fichier_Exist(Fichier) = True Then
Set fso = CreateObject("Scripting.FileSystemObject")
Fichier_extension = fso.GetExtensionName(Fichier)
Set fso = Nothing
End If
End Function
'Copie un fichier d'une source vers une destination.
Public Sub Copie_Fichier(Source, Destination)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile Source, Destination, True
Set fso = Nothing
End Sub
'Déplace un ou plusieurs fichiers d'un emplacement source vers une destination.
Public Sub Deplace_Fichier(Source, Destination)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.MoveFile Source, Destination
Set fso = Nothing
End Sub
'Supprime le ou les fichiers dont le nom est précisé en argument.
Public Sub Supprimer_Fichier(DelFichier)
If Fichier_Exist(DelFichier) = True Then
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile DelFichier, True
Set fso = Nothing
End If
End Sub
Function AppendTxt(sFile, sText)
Dim fso, NewFichier
Set fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = fso.OpenTextFile(sFile, 8)
NewFichier.Write sText
NewFichier.Close
Set NewFichier = Nothing
Set fso = Nothing
End Function
Public Sub FichierLog(sFile, txt)
Dim FichierLog, fso
FichierLog = sFile
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(FichierLog) = False Then EnteteFichier FichierLog
AppendTxt FichierLog, txt
Set fso = Nothing
End Sub
Private Sub EnteteFichier(Fichier)
Dim txt, fso, NewFichier
txt = "***********************************************************************************************************************************************************************************"
txt = txt & vbCrLf
txt = txt & ""
txt = txt & vbCrLf
txt = txt & "   Date de création: " & Day(Now) & "/" & Month(Now) & "/" & Year(Now) & " " & Hour(Time) & ":" & Minute(Time) & vbCrLf
txt = txt & vbCrLf
txt = txt & "   " & Fichier
txt = txt & vbCrLf
txt = txt & "***********************************************************************************************************************************************************************************"
txt = txt & vbCrLf
txt = txt & vbCrLf
txt = ""
Set fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = fso.OpenTextFile(Fichier, 2, True)
NewFichier.Write txt
NewFichier.Close
Set NewFichier = Nothing
Set fso = Nothing
End Sub
Public Function OuvrirFichier(Fichier)
Set oFs = CreateObject("Scripting.FileSystemObject")
Set oFile = oFs.OpenTextFile(Fichier)
OuvrirFichier = Split(oFile.ReadAll, vbCrLf)
oFile.Close
End Function

[loufab]

Je pensais plutôt à cette page :

https://technet.microsoft.com/en-us/...or=-2147217396