Recherche récursive + déplacement fichiers .pst

**AbunaE** · 30/03/2011, 10h44

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

**l_autodidacte** · 30/03/2011, 20h55

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 :

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

**AbunaE** · 30/03/2011, 21h06

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

**hackoofr** · 30/03/2011, 23h04

Envoyé par AbunaE

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

essaye ce code :

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

**l_autodidacte** · 30/03/2011, 23h36

Nouvelle version :

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

**AbunaE** · 31/03/2011, 13h52

Merci beaucoup !!!

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

Merki

Recherche récursive + déplacement fichiers .pst

VBScript

Vue hybride

Discussions similaires

Partager

Partager