parcourir fichier .pst

Version imprimable

Bonjour,

Je veux faire un script qui permet de parcourir les fichiers sous C:\%userprofile% et chercher les fichiers .pst afin de les déplacer vers un autre emplacement.

Src="C:\%userprofile%" ne fonctionne pas. Merci de m'aider

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
40
41
42
43
44
45
46
47
48
49
50
51
52
 
Option Explicit
 
 Dim fso, oFolder, WS, Ret,oSubFold,fich, Src,Dest
 
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set WS = CreateObject("WScript.Shell")
 
 Src="C:\%userprofile%\"
 Dest="H:\" 
 
 Set oFolder = fso.GetFolder(src)
 CreateFolders Dest
 ScanForFile Src, Dest
' ===================================
Sub ScanForFile(srcFolder,DestFolder)
    For Each Fich In oFolder.Files
        On error resume next
	   If Ucase(fso.GetExtensionName(Fich.Name))="PST" Then
	      fso.MoveFile Fich.Path, DestFolder & "\" & fso.GetBaseName(Fich.Name) &  ".pst"
	   End If
	Next   
 
	For Each oSubFold In oFolder.SubFolders
	   For Each Fich In OsubFold.Files 
	      If Ucase(fso.GetExtensionName(Fich.Name))="PST" Then
	        fso.MoveFile Fich.Path, DestFolder & "\" & fso.GetBaseName(Fich.Name) &  ".pst"
	      End If
	   Next	  
	Next
End Sub
' =================================
Function CreateFolders(Fldr)
  Dim OldFolder, tb, I, NextFolder,Root
  If fso.FolderExists(Fldr) Then 
      CreateFolders=Fldr
	  Exit Function
  End If	  
  tb=Split(fldr,"\") 
  Root="c:\"
  On Error Resume Next
  For I=1 to Ubound(tb)
   If fso.FolderExists(Root & tb(I)) Then
      Set OldFolder=fso.GetFolder(Root & tb(I))
   ElseIf fso.FolderExists(Root & tb(I)) = False Then
      Set OldFolder=fso.GetFolder(Root)
      Set NextFolder = fso.CreateFolder(OldFolder.Path & "\" & tb(I))
   End If
   Root=NextFolder.Path & "\"
  Next
  CreateFolders=NextFolder.Path
End Function

05/03/2019, 12h48
l_autodidacte

Modifie la ligne 9 pour avoir : Src = WS.ExpandEnvironmentStrings("%USERPROFILE%")
05/03/2019, 14h42
chaima01

Bonjour,

Merci l_autodidacte pour votre réponse. j'ai fait le changement de la ligne 9 mais le script n'a pas fonctionné et n'affiche aucune erreur :(
05/03/2019, 21h43
l_autodidacte

Il faut mettre les 2 instructions On Error Resume Next en commentaire car elles masquent les erreurs éventuelles.

J'aimerais savoir si les fichiers .pst sont tous dans le dossier "Utilisateur" ou bien dans des sous-dossiers de ce dernier.
Dans la fonction CreateFolders, la variable root doit être initialisée à root = H:\ car la création de dossiers et sous-dossiers concerne l'endroit où on copierait les fichiers et non pas le lecteur source.

Les fichiers .pst sont tous dans des sous-dossiers de dossier "Utilisateur".
j'ai fait les changements que vous m'avez indiqués, mais je reçois le message d'erreur Permission refusée à la ligne 22.

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
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Option Explicit
 
 Dim fso, oFolder, WS, Ret,oSubFold,fich, Src,Dest
 
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set WS = CreateObject("WScript.Shell")
 Src = WS.ExpandEnvironmentStrings("%USERPROFILE%")
 Dest="H:\" 
 Set oFolder = fso.GetFolder(src)
 CreateFolders Dest
 ScanForFile Src, Dest
' ===================================
Sub ScanForFile(srcFolder,DestFolder)
    For Each Fich In oFolder.Files
        'On error resume next
	   If Ucase(fso.GetExtensionName(Fich.Name))="PST" Then
	      fso.MoveFile Fich.Path, DestFolder & "\" & fso.GetBaseName(Fich.Name) &  
 
".pst"
	   End If
	Next   
 
	For Each oSubFold In oFolder.SubFolders
	   For Each Fich In OsubFold.Files 
	      If Ucase(fso.GetExtensionName(Fich.Name))="PST" Then
	        fso.MoveFile Fich.Path, DestFolder & "\" & fso.GetBaseName(Fich.Name) &  
 
".pst"
	      End If
	   Next	  
	Next
End Sub
' =================================
Function CreateFolders(Fldr)
  Dim OldFolder, tb, I, NextFolder,Root
  If fso.FolderExists(Fldr) Then 
      CreateFolders=Fldr
	  Exit Function
  End If	  
  tb=Split(fldr,"\") 
  Root="H:\"
  'On Error Resume Next
  For I=1 to Ubound(tb)
   If fso.FolderExists(Root & tb(I)) Then
      Set OldFolder=fso.GetFolder(Root & tb(I))
   ElseIf fso.FolderExists(Root & tb(I)) = False Then
      Set OldFolder=fso.GetFolder(Root)
      Set NextFolder = fso.CreateFolder(OldFolder.Path & "\" & tb(I))
   End If
   Root=NextFolder.Path & "\"
  Next
  CreateFolders=NextFolder.Path
End Function

07/03/2019, 13h23
l_autodidacte

La ligne 22 est vide.

Essaie de supprimer les lignes vides pour avoir l'endroit correct de l'erreur.
07/03/2019, 18h33
ProgElecT

Salut

:coucou: l_autodidacte

Pour infos, le débogueur supprime les lignes vides mais aussi les débuts de colonnes vides elles aussi, c'est pourquoi le renseignement retourné ligne/colonne est à prendre avec des pincettes.
08/03/2019, 07h39
l_autodidacte

Salut ProgElecT :coucou:

Mon débogueur, un peu moins paresseux, compte les CR pour qu'il puisse se retrouver. Il compte aussi les espaces avant, prend un vbTab comme étant une unité.

salut l_autodidacte

l'erreur est devenu à la ligne 19 " Permission refusée".

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
40
41
42
43
44
45
46
Option Explicit
Dim fso, oFolder, WS, Ret,oSubFold,fich, Src,Dest
Set fso = CreateObject("Scripting.FileSystemObject")
Set WS = CreateObject("WScript.Shell")
Src = WS.ExpandEnvironmentStrings("%USERPROFILE%")
Dest="H:\" 
Set oFolder = fso.GetFolder(src)
CreateFolders Dest
ScanForFile Src, Dest
' ===================================
Sub ScanForFile(srcFolder,DestFolder)
    For Each Fich In oFolder.Files
        'On error resume next
	   If Ucase(fso.GetExtensionName(Fich.Name))="PST" Then
	      fso.MoveFile Fich.Path, DestFolder & "\" & fso.GetBaseName(Fich.Name) & ".pst"
	   End If
	Next   
	For Each oSubFold In oFolder.SubFolders
	   For Each Fich In OsubFold.Files 
	      If Ucase(fso.GetExtensionName(Fich.Name))="PST" Then
	        fso.MoveFile Fich.Path, DestFolder & "\" & fso.GetBaseName(Fich.Name) & ".pst"
	      End If
	   Next	  
	Next
End Sub
' =================================
Function CreateFolders(Fldr)
  Dim OldFolder, tb, I, NextFolder,Root
  If fso.FolderExists(Fldr) Then 
      CreateFolders=Fldr
	  Exit Function
  End If	  
  tb=Split(fldr,"\") 
  Root="H:\"
  'On Error Resume Next
  For I=1 to Ubound(tb)
   If fso.FolderExists(Root & tb(I)) Then
      Set OldFolder=fso.GetFolder(Root & tb(I))
   ElseIf fso.FolderExists(Root & tb(I)) = False Then
      Set OldFolder=fso.GetFolder(Root)
      Set NextFolder = fso.CreateFolder(OldFolder.Path & "\" & tb(I))
   End If
   Root=NextFolder.Path & "\"
  Next
  CreateFolders=NextFolder.Path
End Function

08/03/2019, 08h55
l_autodidacte

Il se peut que les droits d'accès à certains sous-dossiers soient restreints ou que l'un des fichiers soit en cours d'utilisation.
Essaie de modifier ces droits pour les sous-dossiers en question en mettant "Contrôle total"