Discussion :

[VinceMees]

Bonjour tout le monde,

Je suis bloqué sur un script qui me permet de faire du ménage sur des répertoires communs.
Le but du script est de créer une copie des répertoires en respectant l'arborescence et antérieur à une date défini.
Mon problème se pose sur les répertoires sur lesquels je n'ai pas les droits, je ne souhaite faire aucune action sur ces répertoires. Ils doivent donc rester dans le répertoire source.
Erreur : Permission refusée
Code : 800A0046
Le but du jeu est passer au répertoire suivant et de continuer à se dérouler.
J'ai réussi en rajoutant "on error resume next" à deux endroits du code, à ne plus afficher le message d'erreur, le script continue donc à s’exécuter en effectuant la copie de tout les répertoires suivants mais sans les fichiers se trouvant à l'intérieur.

Merci pour 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
'Variable d'execution du Script
lectsource = "E:\Datas\Commun\" 'Lecteur Source des fichiers à analyser
lectdest = "E:\Archives Commun\Commun\" 'Lecteur de Destination
jourdepl = "01" 'Jour de la date d'archivage
moisdepl = "07" 'Mois de la date d'archivage
anneedepl = "2015" 'Année de la date d'archivage

'Lancement du VBS sur le lecteur source
deplacementfichier lectsource

'procédure d'analyse et d'action sur les fichiers
Sub deplacementfichier(fullPath) 
Dim fso, ws
Set ws = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(fullPath)
On Error Resume Next
    For Each Fichier In Dossier.Files 
      If dateserial(year(Fichier.DateLastModified),month(Fichier.DateLastModified),day(Fichier.DateLastModified)) <=  dateserial(anneedepl, moisdepl, jourdepl) Then
             'recup du chemin de fichier
            valeurfich = 1
            while left(Right(fullpath, valeurfich),1) <> "\"
            valeurfich = valeurfich +1
            Wend
            valdecoup = len(left(fullpath, len(fullpath)-len(Right(fullpath, valeurfich))+1))-len(lectsource)
            if valdecoup < 0 then valdecoup = 0
            cheminfichier = right(left(fullpath, len(fullpath)-len(Right(fullpath, valeurfich))+1),valdecoup)
            'appel pour recréation de l'arborescence
            CreateSubDirectories(lectdest & cheminfichier)
            'copie (copyFile) ou déplacement (moveFile) du fichier
            fso.moveFile Fichier.path, lectdest & right(Fichier.path,len(Fichier.path)-len(lectsource)), true
        End If
On Error Resume Next
    Next 
    'Même Analyse pour tous les sous-repertoires
    For Each SousDossier In Dossier.SubFolders
        CreateSubDirectories(lectdest & right(SousDossier.Path,len(SousDossier.path)-len(lectsource))) 'Permet la recréation d'un dossier même si vide ou rien à déplacer
        deplacementfichier SousDossier.Path
    Next 
End Sub

'procédure de recréation de l'arborescence
Sub CreateSubDirectories(fullPath)
On error resume next
Set objFSO = CreateObject("Scripting.FileSystemObject")
str = fullPath
If Right(str, 1) <> "\" Then
 str = str & "\"
End If
strArray = Split(str, "\")
basePath = strArray(0) & "\"
For i = 1 To UBound(strArray) - 1
  If Len(newPath) = 0 Then
    newPath = basePath & newPath & strArray(i) & "\"
  Else
    newPath = newPath & strArray(i) & "\"
  End If
Set objFolder = objFSO.CreateFolder(newPath)
Next
End Sub

[VinceMees]

Après de multiples essais, le problème est résolu.
Voici la solution

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
 
'Variable d'execution du Script
lectsource = "E:\Datas\Commun\" 'Lecteur Source des fichiers à analyser
lectdest = "E:\Archives Commun\Commun\" 'Lecteur de Destination
jourdepl = "01" 'Jour de la date d'archivage
moisdepl = "07" 'Mois de la date d'archivage
anneedepl = "2015" 'Année de la date d'archivage
 
'Lancement du VBS sur le lecteur source
deplacementfichier lectsource
 
'procédure d'analyse et d'action sur les fichiers
Sub deplacementfichier(fullPath) 
Dim fso, ws
Set ws = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(fullPath)
    For Each Fichier In Dossier.Files 
On error resume next
      If dateserial(year(Fichier.DateLastModified),month(Fichier.DateLastModified),day(Fichier.DateLastModified)) <=  dateserial(anneedepl, moisdepl, jourdepl) Then
             'recup du chemin de fichier
            valeurfich = 1
            while left(Right(fullpath, valeurfich),1) <> "\"
            valeurfich = valeurfich +1
            Wend
            valdecoup = len(left(fullpath, len(fullpath)-len(Right(fullpath, valeurfich))+1))-len(lectsource)
            if valdecoup < 0 then valdecoup = 0
            cheminfichier = right(left(fullpath, len(fullpath)-len(Right(fullpath, valeurfich))+1),valdecoup)
            'appel pour recréation de l'arborescence
            CreateSubDirectories(lectdest & cheminfichier)
            'copie (copyFile) ou déplacement (moveFile) du fichier
            fso.moveFile Fichier.path, lectdest & right(Fichier.path,len(Fichier.path)-len(lectsource)), true
        End If
    Next 
    'Même Analyse pour tous les sous-repertoires
    For Each SousDossier In Dossier.SubFolders
        CreateSubDirectories(lectdest & right(SousDossier.Path,len(SousDossier.path)-len(lectsource))) 'Permet la recréation d'un dossier même si vide ou rien à déplacer
        deplacementfichier SousDossier.Path
    Next 
    On error GoTo 0
End Sub
 
'procédure de recréation de l'arborescence
Sub CreateSubDirectories(fullPath)
On error resume next
Set objFSO = CreateObject("Scripting.FileSystemObject")
str = fullPath
If Right(str, 1) <> "\" Then
 str = str & "\"
End If
strArray = Split(str, "\")
basePath = strArray(0) & "\"
For i = 1 To UBound(strArray) - 1
  If Len(newPath) = 0 Then
    newPath = basePath & newPath & strArray(i) & "\"
  Else
    newPath = newPath & strArray(i) & "\"
  End If
Set objFolder = objFSO.CreateFolder(newPath)
Next
End Sub