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
| Option Explicit
Dim booErreur, booCorrespondance
Dim strMessageFinal, strTypeMessage, strTitreMessage, strDossierRacine, strCheminDossierEcriture, strCodeProprietaireRecherche
Dim objFSO, objDossierRacine, objFichierResultat, objFichierLog
Const conFichierResultat = "Listing_fichiers.txt"
Const conFichierLog = "LogsRecuperation.txt"
Const conEcriture = 2 'spécifie que le fichier est en écriture
booErreur = False 'initialisation de présence d'erreur à False
booCorrespondance = False 'initialisation de correspondance entre propriétaires à False
Do
strCodeProprietaireRecherche = InputBox("Saisir le code de l'utilisateur recherché (UserName) :","Code de l'utilisateur","Code utilisateur")
Loop While (strCodeProprietaireRecherche = "Code utilisateur") 'Boucle tant que strCodeProprietaireRecherche = "Code utilisateur"
If strCodeProprietaireRecherche <> "" Then 'si strCodeProprietaireRecherche est non null alors exécution, sinon rien
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDossierRacine = funcSelectionRepertoire(False, " de recherche") 'sélection du dossier de base en graphique
strCheminDossierEcriture = funcSelectionRepertoire(True, " de résultats") 'sélection du dossier dans lequel mettre tous les résultats
Set objDossierRacine = objFSO.GetFolder(strDossierRacine)
Set objFichierResultat = objFSO.OpenTextFile(strCheminDossierEcriture & "\" & conFichierResultat, conEcriture, True)
Set objFichierLog = objFSO.OpenTextFile(strCheminDossierEcriture & "\" & conFichierLog, conEcriture, True)
subParcourirArborescence objDossierRacine, objFichierResultat, objFichierLog, strCodeProprietaireRecherche
If booErreur Then
MsgBox "Des erreurs sont survenues durant l'exécution du script, veuillez consulter le fichier " & conFichierLog & vbcrlf & "Script terminé", vbCritical, "Erreur"
Else
MsgBox "Script terminé", vbInformation, "Fin"
End If
Else 'si Annuler est sélectionné
MsgBox "Vous avez annulé l'exécution du script", vbCritical, "Annulation"
End If
'=============================== Procédures et fonctions ===============================================
Function funcSelectionRepertoire(booCreationAutorisee, strDescriptionDemande)
Const conReturnOnlyFSDirs = &H1
Const conNoNewFolderButton = &H200
Dim objShell, objDossier, objDossierChoisi
Set objShell = CreateObject("Shell.Application")
If booCreationAutorisee Then
Set objDossier = objShell.BrowseForFolder(&H0&, "Choisir un répertoire" & strDescriptionDemande, conReturnOnlyFSDirs)
Else
Set objDossier = objShell.BrowseForFolder(&H0&, "Choisir un répertoire" & strDescriptionDemande, conReturnOnlyFSDirs + conNoNewFolderButton)
End If
If objDossier Is Nothing Then
MsgBox "Vous n'avez rien sélectionné", vbCritical, "Abandon"
Wscript.Quit
Else
Set objDossierChoisi = objDossier.Self
funcSelectionRepertoire = objDossierChoisi.Path
End If
Set objShell = Nothing
Set objDossier = Nothing
Set objDossierChoisi = Nothing
End Function
Sub subParcourirArborescence(objDossierParent, objFichierEcriture, objFicLog, strCodeProprietaireRecherche) 'parcourt l'arborescence de façon RECURSIVE tous les fichiers et les dossiers
Dim colFicArbo, colSousDossiers
Dim objFicArbo, objDossierArbo
Dim strNomProprio
Set colFicArbo = objDossierParent.Files
If colFicArbo.Count <> 0 Then 'vérifie qu'il y a des fichiers
For Each objFicArbo In colFicArbo 'Non récursif
strNomProprio = funcObtenirProprietaire(objFicArbo.Path, objFicLog)
If funcComparaisonChaineCaractere(strCodeProprietaireRecherche, strNomProprio) Then
objFichierEcriture.WriteLine objFicArbo.Path
End If
Next
End If
Set colSousDossiers = objDossierParent.SubFolders
If colSousDossiers.Count <> 0 Then 'vérifie qu'il y a des sous-dossiers
For Each objDossierArbo In colSousDossiers
strNomProprio = funcObtenirProprietaire(objDossierArbo.Path, objFicLog)
If funcComparaisonChaineCaractere(strCodeProprietaireRecherche, strNomProprio) Then
objFichierEcriture.WriteLine objDossierArbo.Path
End If
subParcourirArborescence objDossierArbo, objFichierEcriture, objFicLog, strCodeProprietaireRecherche 'RECURSIVITE !!!!!
Next
End If
End Sub
Function funcObtenirProprietaire(strCheminObjetArbo, objFicLog) 'renvoie le UserName du propriétaire
Dim objWMIDroits, objWMISecurityDescriptor
Dim RetVal
On Error Resume Next
Err.Clear
Set objWMIDroits = GetObject("winmgmts:").Get("win32_LogicalFileSecuritySetting='" & strCheminObjetArbo & "'")
RetVal = objWMIDroits.GetSecurityDescriptor(objWMISecurityDescriptor)
If Err <> 0 Then
subGestionErreur objFicLog, strCheminObjetArbo, Err.Number, Err.Description
Else
If RetVal <> 0 Then
subGestionErreur objFicLog, strCheminObjetArbo, RetVal, "Impossible de récupérer le descripteur de sécurité"
Else
funcObtenirProprietaire = objWMISecurityDescriptor.Owner.Name
End If
End If
On Error Goto 0 'fin de la gestion d'erreur
End Function
Function funcComparaisonChaineCaractere(strChaineReference, strChaineComparaison)
strChaineReference = UCase(strChaineReference)
strChaineComparaison = UCase(strChaineComparaison)
funcComparaisonChaineCaractere = Eval("strChaineReference = strChaineComparaison")
End Function
Sub subGestionErreur(objFicLog, strCheminErreur, intNumeroErreur, strDescriptionErreur)
booErreur = True
objFicLog.WriteLine "L'erreur porte sur : " & strCheminErreur
objFicLog.WriteLine "Numéro d'erreur : " & intNumeroErreur
objFicLog.WriteLine "Description d'erreur : " & strDescriptionErreur & vbcrlf
End Sub |
