Recherche récursive + déplacement fichiers .pst

Version imprimable

30/03/2011, 10h44
AbunaE

Recherche récursive + déplacement fichiers .pst

Bonjour,

Je voudrais faire tourner un script VB qui:

- parcours une arborescence I:\USERS\
- si un .pst est trouvé dans un dossier I:\USERS\XXXXXXX\ ou un sous-dossier de celui-ci, le déplace dans I:\ARCHIVES\USERS\XXXXXXXX\Archives Outlook
- n'écrase pas les .pst de même nom mais rajoute un chiffre à la fin, ex : archive01.pst

Le problème est que je n'y connais rien en VB. J'ai trouvé des exemples à droite à gauche mais je n'arrive pas à les adapter à mon cas.

Une âme charitable pourrait m'aider?

Merci

Bonsoir et bienvenu sur DVP

Étant donnée ton honnêteté, et vu que c'est ta première visite sur ce site, je te propose ce

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="C:\User" ' A modifier selon le besoin
 Dest="C:\Archives\User\XXXXXX" ' et cette ligne aussi
 Set oFolder = fso.GetFolder(src)
 CreateFolders Dest
 ScanForFile Src, Dest
' ===================================
Sub ScanForFile(srcFolder,DestFolder)
    For Each Fich In oFolder.Files
	   If Ucase(fso.GetExtensionName(Fich.Name))="PST" Then
	      fso.MoveFile Fich.Path, DestFolder & "\" & fso.GetBaseName(Fich.Name) & TransformDateTime & ".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) & TransformDateTime & ".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
' =================================
Function TransformDateTime()
 TransformDateTime="_" & Day(Now) &"_"& Month(Now) & "_" & Year(Now) & "_" & Hour(Now) & "_" _
   & Minute(Now) & "_" & Second(Now)
End Function

Mais tu devrais t'y faire un jour.

30/03/2011, 21h06
AbunaE

Whoua !! Je pensais pas avoir une réponse :)

J'ai avancé un peu de mon côté aujourd'hui et il me manquait les log là.

En fait, à chaque déplacement, je voudrai écrire dans un fichier la source et la destination mais lorsque je lance le script j'ai un 'permission refusée'. Pourtant niveau NTFS tout est OK.

Merci beaucoup pour le script, je vais l'analyser :)
Il est surement mieux que le mien XD

Citation:

Envoyé par AbunaE

J'ai avancé un peu de mon côté aujourd'hui et il me manquait les log là.

:salut:
essaye ce code :

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
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
start_folder = ".\"  ' à modifier le chemin du dossier source
dest_folder = "c:\deplace"   'à modifier le chemin du dossier de destination
htmfile = "Liste_pst.htm"  'Fichier Log en Html
ext = Array("pst") 'extensions des fichiers .pst à rechercher
count=0
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(start_folder)
Set destination = fso.GetFolder(dest_folder)
Set ws = CreateObject("WScript.Shell")
Set outfile = fso.CreateTextFile(htmfile)
 
strHTML="<html><body><style type='text/css'>"&_
"a:link {color: #F19105;}"&_
"a:visited {color: #F19105;}"&_
"a:active {color: #F19105;}"&_
"a:hover {color: #FF9900;background-color: rgb(255, 255, 255);}"&_
"</style>"
 
strHTML=strHTML &"<center><h2><B><font color=red>Le Nombre Total de Fichiers de type .pst qui ont été déplacé est de [COUNT]</font></B></h2></center>" & _
              "<table border='1' style='border-collapse: collapse; font size:9pt' bordercolor='#CCCCCC' width='100%' id='Table1'>" & _
              "<tr><td><center><strong>Fichier Source</strong></center></td><td><center><strong>Chemin du Dossier Destination</strong></center></td>" & _
              "<td><center><strong>Taille<strong></center></td><td><center><strong>Type</strong></center></td>" & _
              "<td><center><strong>Modifié le</strong></center></td><td><center><strong>Dernier Accès</strong></center></td></tr>" 
ListDirectory folder,ext,destination
strHTML = strHTML & "</table>"
strHTML = Replace(strHTML, "[COUNT]", Count) 
outfile.WriteLine strHTML &"</body></html>"
outfile.Close
 
Explorer htmfile
 
Sub ListDirectory(folder,ext,destination)
 
    For Each objFile In folder.Files
     cheminFic = folder & "\" & objFile.name
      For i = lbound(ext) to ubound(ext)
        If UCase(ext(i)) = UCase(fso.GetExtensionName(objFile.Name)) Then
            count=count+1
            strFileName = objFile.Name
            strFilePath = objFile.ParentFolder
            strFileSize = FormatNumber((objFile.Size/1024),2) + " Kb"
            strFileType = objFile.Type
            strFileModified = objFile.DateLastModified
            strFileAccess = objFile.DateLastAccessed
 
            strHTML = strHTML & "<tr><td>"& cheminFic &"</td><td><a href='" & dest_folder & "'>" & _
                                dest_folder & "</a></td><td>" & strFileSize & "</td>" & _
                                "<td>" & strFileType & "</td><td>" & strFileModified & "</td>" & _
                                "<td>" & strFileAccess & "</td></tr>"
 
'MsgBox objFile	
 
i=0
if fso.FileExists(destination & "\" & strFileName)  Then
i = i + 1
	Deplacer objFile , destination & "\" & strFileName & i
else
	Deplacer objFile , destination & "\" & strFileName 	
end if
 
        End If
    Next
       Next
    For Each fldr In folder.subfolders
        ListDirectory fldr, ext ,destination
    Next
End Sub
 
Function Explorer(File)
    Set ws=CreateObject("wscript.shell")
    ws.run "Explorer "& File & "\"
end Function
 
Function Deplacer(source,cible)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.MoveFile source,cible
end Function

Nouvelle version :

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
54
55
56
57
58
59
60
61
62
63
Option Explicit
 
 Dim fso, oFolder, oSubFold,fich, Src,Dest, NewFich
 
 Set fso = CreateObject("Scripting.FileSystemObject")
 Src="C:\User"
 Dest="C:\Archives\User\XXXXXX"
 Set oFolder = fso.GetFolder(src)
 CreateFolders Dest
 ScanForFile Src, Dest
' ===================================
Sub ScanForFile(srcFolder,DestFolder)
    For Each Fich In oFolder.Files
	   If Ucase(fso.GetExtensionName(Fich.Name))="PST" Then
          NewFich=DestFolder & "\" & fso.GetBaseName(Fich.Name) & TransformDateTime & ".pst"
	      WriteLog Fich.Path, NewFich
		  fso.MoveFile Fich.Path, NewFich
	   End If
	Next   
 
	For Each oSubFold In oFolder.SubFolders
	   For Each Fich In OsubFold.Files 
	      If Ucase(fso.GetExtensionName(Fich.Name))="PST" Then
		    NewFich=DestFolder & "\" & fso.GetBaseName(Fich.Name) & TransformDateTime & ".pst"
		    WriteLog Fich.Path, NewFich
	        fso.MoveFile Fich.Path, NewFich
	      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
' =================================
Function TransformDateTime()
 TransformDateTime="_" & Day(Now) &"_"& Month(Now) & "_" & Year(Now) & "_" & Hour(Now) & "_" _
   & Minute(Now) & "_" & Second(Now)
End Function
' ==============================
Sub WriteLog(srcFile, DestFile)
  Dim f
  Set f=fso.OpenTextFile(Dest & "\Journal.log",8,True) 
  f.WriteLine " ====> " & srcFile & "    déplacé vers :   " & DestFile
  f.close
End Sub

31/03/2011, 13h52
AbunaE

Merci beaucoup !!!

Je vais tester ça et je vous tiens au courant !!

Merki

Bon, alors de mon côté j'avais avancé aussi en prenant des infos à droite et à gauche et en m'appuyant sur les vôtres.

J'ai 2 problèmes:
- le script tourne en boucle depuis que j'ai fait des modifications pour bien tout organiser ... je ne vois pas où est le problème. Le 'Exit for' mal placé?
- dans mon log, en source et en destination et j'ai la même chose à savoir, la destination. Je ne comprend pas non plus.

Vous pouvez me corriger svp? De cette manière, ca sera plus formateur pour moi.

Merci

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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
dim objFSO, readfile, user , ExtToMove
 
set objFSO = CreateObject("Scripting.FileSystemObject")
set readfile = objFSO.OpenTextFile("users.txt", 1, false)
 
user = readfile.ReadLine
srcFolder = "I:\USERS\" & user
tgtFolder = "I:\ARCHIVES\USERS\" & user & "\Archives Outlook\"
ExtToMove = "pst"
 
do while readfile.AtEndOfStream=false
 
MoveFiles srcFolder,ExtToMove
 
loop
 
readfile.close
 
wscript.echo "Termine"
 
sub MoveFiles(BYVAL srcFolder,ExtToMove)
 
	dim objFolder, objSubFolder, objFile
	dim strExt
	dim altTime
	dim altDate
 
	set objFolder = objFSO.GetFolder(srcFolder)
 
	altTime = Replace(time, ":", "")
	altDate = Replace(date, "/", "")
 
	for each objFile in objFolder.Files
		for each strExt in SPLIT(UCASE(ExtToMove),",")
			if RIGHT(UCASE(objFile.Path),LEN(strExt)+1) = "." & strExt then
 
				wscript.echo "Moving:" & objFile.Path
				name = objFSO.GetFileName(objFile)
 
                If objFSO.FileExists(tgtFolder & name) then					
				  objFSO.MoveFile objFile , tgtFolder & altDate & altTime & "-" & name
                  WriteLog objFile, tgtFolder & altDate & altTime & "-" & name
				else
				  objFile.Move(tgtFolder)
				  WriteLog objFile, tgtFolder & name
				end if				
			exit for
 
			end if
		next
	next
 
	for each objSubFolder in objFolder.SubFolders
		MoveFiles objSubFolder.Path,ExtToMove
	next
 
end sub
 
sub WriteLog(srcFile, DestFile)
 
  dim f
 
  set f=objFSO.OpenTextFile("MoveFiles_log.txt",8,True) 
 
  f.WriteLine " ====> " & srcFile & "    déplacé vers :   " & DestFile
  f.close
 
end sub

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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
 
 
dim objFSO, readfile, user , ExtToMove
 
set objFSO = CreateObject("Scripting.FileSystemObject")
set readfile = objFSO.OpenTextFile("users.txt", 1, false)
 
user = readfile.ReadLine
srcFolder = "I:\USERS\" & user
tgtFolder = "I:\ARCHIVES\USERS\" & user & "\Archives Outlook\"
ExtToMove = "pst"
 
do while readfile.AtEndOfStream=false
 
MoveFiles srcFolder,ExtToMove
 
loop
 
readfile.close
 
wscript.echo "Termine"
 
sub MoveFiles(BYVAL srcFolder,ExtToMove)
 
	dim objFolder, objSubFolder, objFile
	dim strExt
	dim altTime
	dim altDate
 
	set objFolder = objFSO.GetFolder(srcFolder)
 
	altTime = Replace(time, ":", "")
	altDate = Replace(date, "/", "")
 
	for each objFile in objFolder.Files
		for each strExt in SPLIT(UCASE(ExtToMove),",")
			if RIGHT(UCASE(objFile.Path),LEN(strExt)+1) = "." & strExt then
 
				wscript.echo "Moving:" & objFile.Path
				name = objFSO.GetFileName(objFile)
 
                If objFSO.FileExists(tgtFolder & name) then					
				  objFSO.MoveFile objFile , tgtFolder & altDate & altTime & "-" & name
                  WriteLog objFile, tgtFolder & altDate & altTime & "-" & name
				else
				  objFile.Move(tgtFolder)
				  WriteLog objFile, tgtFolder & name
				end if				
			exit for
 
			end if
		next
	next
 
	for each objSubFolder in objFolder.SubFolders
		MoveFiles objSubFolder.Path,ExtToMove
	next
 
end sub
 
sub WriteLog(srcFile, DestFile)
 
  dim f
 
  set f=objFSO.OpenTextFile("MoveFiles_log.txt",8,True) 
 
  f.WriteLine " ====> " & srcFile & "    déplacé vers :   " & DestFile
  f.close
 
end sub

31/03/2011, 15h49
AbunaE
J'ai résolu mon premier problème en remettant
Code:

1 2 3 4 user = readfile.ReadLine srcFolder = "I:\USERS\" & user tgtFolder = "I:\ARCHIVES\USERS\" & user & "\Archives Outlook\" ExtToMove = "pst"
dans la boucle loop

Reste le problème du log où j'ai la source qui est égal à la destination:

====> I:\ARCHIVES\USERS\TEST\Archives Outlook\test4.pst déplacé vers : I:\ARCHIVES\USERS\TEST\Archives Outlook\test4.pst
====> I:\ARCHIVES\USERS\TEST\Archives Outlook\test5.pst déplacé vers : I:\ARCHIVES\USERS\TEST\Archives Outlook\test5.pst
====> I:\ARCHIVES\USERS\TEST\Archives Outlook\test6.pst déplacé vers : I:\ARCHIVES\USERS\TEST\Archives Outlook\test6.pst

Quelqu'un peut me corriger le code?

Merci

Ça y est !!

En fait, objFile prend la valeur de la destination après le déplacement ... je ne comprend pas pourquoi. Du coup j'initialise 2 nouvelles valeurs src et dst avant le déplacement et je les utilise pour le log. Ca marche.

Est-ce que quelqu'un peut regarder mon code final et me dire ce qui peut être optimisé? Me dire ce qui ne va pas?

Merci d'avance et merci à ceux qui ont répondu !!

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
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
 
 
dim objFSO, readfile, user , ExtToMove
 
set objFSO = CreateObject("Scripting.FileSystemObject")
set readfile = objFSO.OpenTextFile("users.txt", 1, false)
set logfile = objFSO.OpenTextFile("MoveFiles_log.txt", 2, false)
 
logfile.Write ""
logfile.Close
 
do while readfile.AtEndOfStream=false
 
user = readfile.ReadLine
srcFolder = "I:\USERS\" & user
tgtFolder = "I:\ARCHIVES\USERS\" & user & "\Archives Outlook\"
ExtToMove = "pst"
 
MoveFiles srcFolder,ExtToMove
 
loop
 
 
 
readfile.close
 
wscript.echo "Termine"
 
 
 
 
sub MoveFiles(BYVAL srcFolder,ExtToMove)
 
	dim objFolder, objSubFolder, objFile
	dim strExt
	dim altTime
	dim altDate
 
	set objFolder = objFSO.GetFolder(srcFolder)
 
	altTime = Replace(time, ":", "")
	altDate = Replace(date, "/", "")
 
	for each objFile in objFolder.Files
		for each strExt in SPLIT(UCASE(ExtToMove),",")
			if RIGHT(UCASE(objFile.Path),LEN(strExt)+1) = "." & strExt then
 
				'wscript.echo "Moving:" & objFile.Path
				name = objFSO.GetFileName(objFile)
 
                If objFSO.FileExists(tgtFolder & name) then		
				  src=objFile
				  dst=tgtFolder & altDate & altTime & "-" & name
				  objFSO.MoveFile src , tgtFolder & altDate & altTime & "-" & name
                  WriteLog src, dst
				else
				  src=objFile
				  dst=tgtFolder & name
				  objFile.Move(tgtFolder)
				  WriteLog src, dst		
				end if				
			exit for
 
			end if
		next
	next
 
	for each objSubFolder in objFolder.SubFolders
		MoveFiles objSubFolder.Path,ExtToMove
	next
 
end sub
 
sub WriteLog(srcFile, DestFile)
 
  dim f
 
  set f=objFSO.OpenTextFile("MoveFiles_log.txt",8,True) 
 
  f.WriteLine " ====> " & srcFile & "    moved to :   " & DestFile
  f.close
 
end sub