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