gérer Erreur : Permission refusée Code:800A0046

Version imprimable

Bonjour toutes et tous,
Je liste fichiers et répertoires récursivement, et quand un répertoire ou un fichier est inaccessible, le script s'arrête sur ce dossier malgré un On Error resume next.
Que faire pour passer aux dossiers ou fichiers suivants ?
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 On Error resume next Dim FSO , objNewFile,oF Set FSO = CreateObject("Scripting.FileSystemObject") Set objNewFile = FSO.CreateTextFile ("C:\..\filelist.txt", True, True)'Unicode UTF-16 Set oF = FSO.GetFolder("C:\Users\..\Documents\") WriteFilesAndFolders oF Public Function WriteFilesAndFolders(Folder) For Each Subfolder in Folder.SubFolders objNewFile.WriteLine( SubFolder.Path ) WriteFilesAndFolders Subfolder Next For Each file in Folder.Files objNewFile.WriteLine( file.Path ) Next End Function

14/08/2016, 20h45
l_autodidacte

Tu peux adapter le code de ce POST pour lister les fichiers en plus des dossiers.
14/08/2016, 21h52
erichissime

salut et merci
je vais voir comment ajouter les fichiers ;)

voilà chose faite
merci
La MsgBox n'aime pas les accents :)
Bonne nuit

Code:

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
 Option Explicit 
 
 Const ForWriting = 2
 Dim oFSO, WS,objOut, objErr
 Set oFSO = CreateObject("Scripting.FileSystemObject")
 
 Set objOut = oFSO.OpenTextFile("C:\Users\\\filelist.txt", ForWriting, True, True)
 Set objErr = oFSO.OpenTextFile("C:\Users\\\ErrLogFile.txt", ForWriting, True, True)
 ScanForFilesAndFolders oFSO.GetFolder("C:\Users\\Documents\")
 objOut.Close
 objErr.Close
 MsgBox "Recherche terminée."
 
Sub ScanForFilesAndFolders(oFolder)
    Dim oSubFolder, oFile
    On Error Resume Next    
        If Err.Number <> 0 Then
            objErr.WriteLine("Dossier [" & oFolder.Path & "] inaccessible")
            Err.Clear
        Else
            objOut.WriteLine(oFolder.Path)
        End If
    For Each oSubFolder In oFolder.SubFolders
        If Err.Number <> 0 Then
          objErr.WriteLine("Sous-dossier [" & oSubFolder.Path & "] inaccessible")
          Err.Clear
        Else
          ScanForFilesAndFolders oSubFolder
        End If
	Next
   For Each oFile In oFolder.Files
        If Err.Number <> 0 Then
          objErr.WriteLine("Fichier [" & oFile.Path & "] inaccessible")
          Err.Clear
        Else
	  objOut.WriteLine(oFile.Path)
	End If
    Next
End Sub

Citation:

La MsgBox n'aime pas les accents

Si tu utilises Notepad++ pour taper ton code, c'est lui qui est la cause des lettres accentuées transformées en caractères bizarres.
Dans les paramètres, il faut pré-fixer le codage en ANSI.

On y parvient par le biais du menu Paramétrage => Préférences... Dans la liste de gauche choisir Nouveau document et tout à fait à ~~gauche~~ droite, cocher le bouton d'option ANSI ensuite le bouton Fermer.

Un petit Up pour le code modifié : Les lignes 31 à 38 devraient être déplacées juste après la ligne 21 (quoique en l'état actuel, le script fonctionne).

Je remplacerais la ligne 9 par ScanForFilesAndFolders oFSO.GetFolder(SelectFolder) et ainsi on n'a plus à modifier le script si on veut explorer un autre dossier :

Code:

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
Function SelectFolder()
Dim WSH, Item, lngFlag, Result, DialogTitle, drv, fso
 
    Set WSH = WScript.CreateObject("Shell.Application")
    lngFlag=BIF_RETURNONLYFSDIRS 
    DialogTitle="Sélection de dossier :(Pas de Poste de travail, Favoris réseau et/ou ses sous-éléments)"
    Set Item = WSH.BrowseForFolder(0,DialogTitle,lngFlag, "")
    If Item Is Nothing Then WScript.Quit 0
    Set WS = CreateObject("WScript.Shell")
    Set fso = CreateObject("Scripting.FileSystemObject")
    If LCase(Item.Title) = "poste de travail" Or LCase(Item.Title) = "favoris réseau" Then 
         MsgBox "Mauvais choix de répertoire [" & UCase(Item.Title) & "]" & VbCrLf & _
                 "Choisir un répertoire valide puis réessayer."
         WScript.Quit 0
    End If
    If LCase(Item.Title) = "mes documents" Or LCase(Item.Title) = "bureau"  Then
         Result = WS.ExpandEnvironmentStrings("%UserProfile%") & "\" & Item.Title
    ElseIf Is_Value(Item) Then
       Result = Item.Title
    ' A-t-on sélectionné la racine d'un lecteur ?
        If Right(Result, 2) = ":)" Then 
            ' Quand il s'agit de la racine d'un lecteur il faut tenir compte de son nom
            ' ( ou Label) qui se présente sous la forme NomLecteur(X:)
            Set drv = fso.GetDrive(Left(Right(Result, 3), 2))
            Result = drv.RootFolder
        ElseIf InStr(1, Result, ":") = 0 Then
            Result = Item.ParentFolder.ParseName(Item.Title).Path
        End If
    End If  
   SelectFolder = Result
End Function
'======================
Function Is_Value(obj)
    Dim stmp
    On Error Resume Next
    stmp = " " & obj
    Is_Value = (Err = 0)
    On Error GoTo 0
End Function

15/08/2016, 12h57
erichissime

Ok merci
Au fait le lien "La bible du vbscript" est mort
aurais-tu le fichier par ailleurs ?
16/08/2016, 01h31
l_autodidacte

Merci pour la remarque.

C'est corrigé.
26/08/2016, 23h41
erichissime

Citation:

Envoyé par l_autodidacte

Merci pour la remarque.

C'est corrigé.

merci ;)