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 |
Partager