Recursive folder synchronization using VBScript (Mirror Folders) - vbscript

I've never really written in vbs (once wrote a script that would welcome me on boot) but I'm after a script to essentially perform :
robocopy "folder1" "folder2" /MIR
At the moment what I've got is a copied script from here VBS Mirror, Using the top script :
This code synchronizes the contents (files and subfolders) of two
folders. Each folder is traversed recursively and any missing
subfolders and files are copied both ways. If corresponding folders
contain files with matching file names but with different time stamps,
the file with the newest time stamp will overwrite the older.
SyncFolders.vbs
Option Explicit
ForceScriptEngine("cscript")
Dim wshArgs
Set wshArgs = Wscript.Arguments
If WshArgs.Count = 2 Then
Call SyncFolders(WshArgs.Item(0), WshArgs.Item(1))
' Also run once in reverse to catch mismatching subfolder count:
Call SyncFolders(WshArgs.Item(1), WshArgs.Item(0))
Else
Wscript.Echo("Wrong number of arguments. Syntax: SyncFolders Folder1 Folder2")
Wscript.Sleep(3000) ' To allow Function syntax popup message to be seen.
End If
Sub SyncFolders(strFolder1, strFolder2)
Dim objFileSys
Dim objFolder1
Dim objFolder2
Dim objFile1
Dim objFile2
Dim objSubFolder
Dim arrFolders
Dim i
Set objFileSys = CreateObject("Scripting.FileSystemObject")
arrFolders = Array(strFolder1, strFolder2)
For i = 0 To 1 ' Make sure that missing folders are created first:
If objFileSys.FolderExists(arrFolders(i)) = False Then
wscript.echo("Creating folder " & arrFolders(i))
objFileSys.CreateFolder(arrFolders(i))
End If
Next
Set objFolder1 = objFileSys.GetFolder(strFolder1)
Set objFolder2 = objFileSys.GetFolder(strFolder2)
For i = 0 To 1
If i = 1 Then ' Reverse direction of file compare in second run
Set objFolder1 = objFileSys.GetFolder(strFolder2)
Set objFolder2 = objFileSys.GetFolder(strFolder1)
End If
For Each objFile1 in objFolder1.files
If Not objFileSys.FileExists(objFolder2 & "\" & objFile1.name) Then
Wscript.Echo("Copying " & objFolder1 & "\" & objFile1.name & _
" to " & objFolder2 & "\" & objFile1.name)
objFileSys.CopyFile objFolder1 & "\" & objFile1.name, _
objFolder2 & "\" & objFile1.name
Else
Set objFile2 = objFileSys.GetFile(objFolder2 & "\" & objFile1.name)
If objFile1.DateLastModified > objFile2.DateLastModified Then
Wscript.Echo("Overwriting " & objFolder2 & "\" & objFile1.name & _
" with " & objFolder1 & "\" & objFile1.name)
objFileSys.CopyFile objFolder1 & "\" & objFile1.name, _
objFolder2 & "\" & objFile1.name
End If
End If
Next
Next
For Each objSubFolder in objFolder1.subFolders
Call SyncFolders(strFolder1 & "\" & objSubFolder.name, strFolder2 & _
"\" & objSubFolder.name)
Next
Set objFileSys = Nothing
End Sub
Sub ForceScriptEngine(strScriptEng)
' Forces this script to be run under the desired scripting host.
' Valid arguments are "wscript" or "cscript".
' The command line arguments are passed on to the new call.
Dim arrArgs
Dim strArgs
For Each arrArgs In WScript.Arguments
strArgs = strArgs & " " & Chr(34) & arrArgs & Chr(34)
Next
If Lcase(Right(Wscript.FullName, 12)) = "\wscript.exe" Then
If Instr(1, Wscript.FullName, strScriptEng, 1) = 0 Then
CreateObject("Wscript.Shell").Run "cscript.exe //Nologo " & _
Chr(34) & Wscript.ScriptFullName & Chr(34) & strArgs
Wscript.Quit
End If
Else
If Instr(1, Wscript.FullName, strScriptEng, 1) = 0 Then
CreateObject("Wscript.Shell").Run "wscript.exe " & Chr(34) & _
Wscript.ScriptFullName & Chr(34) & strArgs
Wscript.Quit
End If
End If
End Sub
I changed the :
Sub SyncFolders(strFolder1, strFolder2)
to
Sub SyncFolders(strC:\Users\Zac\Desktop\Folder, strW:\Folder)
and get the error "Expected ')'
I'm sure it's something very obvious, but could someone please tell me what I need to change in that script to make my folders mirror each other?

Since this vbscript force to deal with Cscript engine; you should execute it by a litlle batch like this way :
#echo off
Cscript /nologo SyncFolders.vbs "C:\Users\Zac\Desktop\Folder" "W:\Folder"
pause
Edit :
And if you like to avoid this batch and using Cscript engine,try this :
Option Explicit
'You must only change the absolute paths of the two folders here
Call SyncFolders("C:\Users\Zac\Desktop\Folder","W:\Folder")
'**********************Don't Change nothing below this line *****************************
Sub SyncFolders(strFolder1, strFolder2)
Dim objFileSys
Dim objFolder1
Dim objFolder2
Dim objFile1
Dim objFile2
Dim objSubFolder
Dim arrFolders
Dim i
Set objFileSys = CreateObject("Scripting.FileSystemObject")
arrFolders = Array(strFolder1, strFolder2)
For i = 0 To 1 ' Make sure that missing folders are created first:
If objFileSys.FolderExists(arrFolders(i)) = False Then
'wscript.echo("Creating folder " & arrFolders(i))
objFileSys.CreateFolder(arrFolders(i))
End If
Next
Set objFolder1 = objFileSys.GetFolder(strFolder1)
Set objFolder2 = objFileSys.GetFolder(strFolder2)
For i = 0 To 1
If i = 1 Then ' Reverse direction of file compare in second run
Set objFolder1 = objFileSys.GetFolder(strFolder2)
Set objFolder2 = objFileSys.GetFolder(strFolder1)
End If
For Each objFile1 in objFolder1.files
If Not objFileSys.FileExists(objFolder2 & "\" & objFile1.name) Then
'Wscript.Echo("Copying " & objFolder1 & "\" & objFile1.name & _
' " to " & objFolder2 & "\" & objFile1.name)
objFileSys.CopyFile objFolder1 & "\" & objFile1.name, _
objFolder2 & "\" & objFile1.name
Else
Set objFile2 = objFileSys.GetFile(objFolder2 & "\" & objFile1.name)
If objFile1.DateLastModified > objFile2.DateLastModified Then
'Wscript.Echo("Overwriting " & objFolder2 & "\" & objFile1.name & _
' " with " & objFolder1 & "\" & objFile1.name)
objFileSys.CopyFile objFolder1 & "\" & objFile1.name, _
objFolder2 & "\" & objFile1.name
End If
End If
Next
Next
For Each objSubFolder in objFolder1.subFolders
Call SyncFolders(strFolder1 & "\" & objSubFolder.name, strFolder2 & _
"\" & objSubFolder.name)
Next
Set objFileSys = Nothing
End Sub
'********************************************************************************

Related

zipping files within VB script

I have a script that works perfectly for me to move files, create new folders then delete out old ones, however i am unable to add in a zipping function. I can do this separately but would like it in my script as i only want to run the one scheduled task.
Can anyone help?
Dim theDate, ArchiveDate
Dim CurPath
Dim BackupPath
Dim objFSO, objFolder, objFile
Dim ArchivePath
'theDate = InputBox("Date to archive (ddmmyy)")
theDate = DateAdd("d",-1, date())
dateArray = Split(theDate,"/")
theDate = dateArray(0) & dateArray(1) & Right(dateArray(2),2)
CurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")
BackupPath = CurPath & "\" & thedate
ArchiveDate = CDate(left(theDate,2) & "/" & mid(theDate,3,2) & "/" & right(theDate,2))
ArchivePath = "E:\Log_Folder_1"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(CurPath)
'msgbox CurPath
'msgbox BackupPath
'msgbox ArchiveDate
For Each objFile In objFolder.Files
ModifiedDate = Split(objFile.DateLastModified," ")
If (CDate(ModifiedDate(0)) = ArchiveDate AND objFSO.GetExtensionName(objFile) <> "vbs") Then
'msgbox "yes " & objFile.DateLastModified
If objFSO.FolderExists(BackupPath) = false Then
objFSO.CreateFolder(BackupPath)
End If
objFile.Move BackupPath & "\" & objFile.Name
Else
'msgbox "no " & objFile.DateLastModified
End If
Next
dim filesys
set filesys=CreateObject("Scripting.FileSystemObject")
If filesys.FolderExists(BackupPath) Then
filesys.CopyFolder "E:\Log_Folder_1" & "\" & thedate, "\\Backup_Server\Logs\Log_Folder_1"
End If
If objFSO.FolderExists(CurPath & "\" & theDate) Then
Set delFolder = objFSO.GetFolder(CurPath & "\" & theDate)
delFolder.Delete
End If
Dim keepDays
keepDays = -20
Do Until keepDays=-10
theDate = replace(DateAdd("d",keepDays, date()),"/","")
theDate = left(theDate,4) & right(theDate,2)
If objFSO.FolderExists ("\\Backup_Server\Logs\Log_Folder_1" & "\" & theDate) Then
Set delFolder = objFSO.GetFolder("\\Backup_Server\Logs\Log_Folder_1" & "\" & theDate)
delFolder.Delete
End If
keepDays=keepDays+1
Loop

VBScript - Create text file using folder name during loop

Problem:
This script below is looping through 4+ million files and retrieving file property information to determine what can be purged. The current process is already using 20+GB of RAM and is only half finished.
I've been creating a large batch file to write each subfolders contents to a new text file. This isn't practical because its time consuming and this is the first of several servers that I will be running this process on.
Questions:
-Is it possible to create a new file to write to based on the subfolder loop? (using the object property in place of the file doesn't appear to do the trick)
-Or is is possible to write the contents to the file, then clear the previous data from my temporary memory?
Set objFSO = CreateObject("Scripting.FileSystemObject")
objStartFolder = "C:\Test"
Set objFolder = objFSO.GetFolder(objStartFolder)
Set colFiles = objFolder.Files
For Each objFile in colFiles
On Error Resume Next
If Err Then
MyFile.Write "Error accessing " & objFile & ": " & Err.Description & vbCrLf
Err.Clear
Else
Q="""" 'Wrap quotes around string
strFilePath = Q & objFile.Path & Q
strFileName = Q & objFile.Name & Q
strFileSize = objFile.Size
strFileType = Q & objFile.Type & Q
strFileDateCreated = objFile.DateCreated
strFileDateLastAccessed = objFile.DateLastAccessed
strFileDateLastModified = objFile.DateLastModified
Set objWMIService = GetObject("winmgmts:")
Set objFileSecuritySettings = _
objWMIService.Get("Win32_LogicalFileSecuritySetting=""" & replace(objFile, "\", "\\") & """")
intRetVal = objFileSecuritySettings.GetSecurityDescriptor(objSD)
If intRetVal = 0 Then
strFileOwner = Q & objSD.Owner.Domain & "\" & objSD.Owner.Name & Q
Else
strFileOwner = Q & "Couldn't retrieve security descriptor." & Q
End If
' CreatedDiff = DateDiff("yyyy",strFileDateCreated,Now)
' AccessedDiff = DateDiff("yyyy",strFileDateLastAccessed,Now)
' ModifiedDiff = DateDiff("yyyy",strFileDateLastModified,Now)
' MaxTime = 3 'Max time in years. For days change "yyyy" to "d"
' If (CreatedDiff >= MaxTime) AND (AccessedDiff >= MaxTime) AND (ModifiedDiff >= MaxTime) Then
MyFile.Write strFilePath & "~|~" &_
strFileName & "~|~" &_
strFileSize & "~|~" &_
strFileType & "~|~" &_
strFileDateCreated & "~|~" &_
strFileDateLastAccessed & "~|~" &_
strFileDateLastModified & "~|~" &_
strFileOwner & vbCrLf
' End If
End If
Next
ShowSubfolders objFSO.GetFolder(objStartFolder)
Sub ShowSubFolders(Folder)
For Each Subfolder in Folder.SubFolders
On Error Resume Next
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
For Each objFile in colFiles
On Error Resume Next
If Err Then
MyFile.Write "Error accessing " & objFile & ": " & Err.Description & vbCrLf
Err.Clear
Else
Q="""" 'Wrap quotes around string
strFilePath = Q & objFile.Path & Q
strFileName = Q & objFile.Name & Q
strFileSize = objFile.Size
strFileType = Q & objFile.Type & Q
strFileDateCreated = objFile.DateCreated
strFileDateLastAccessed = objFile.DateLastAccessed
strFileDateLastModified = objFile.DateLastModified
Set objWMIService = GetObject("winmgmts:")
Set objFileSecuritySettings = _
objWMIService.Get("Win32_LogicalFileSecuritySetting=""" & replace(objFile, "\", "\\") & """")
intRetVal = objFileSecuritySettings.GetSecurityDescriptor(objSD)
If intRetVal = 0 Then
strFileOwner = Q & objSD.Owner.Domain & "\" & objSD.Owner.Name & Q
Else
strFileOwner = Q & "Couldn't retrieve security descriptor." & Q
End If
' CreatedDiff = DateDiff("yyyy",strFileDateCreated,Now)
' AccessedDiff = DateDiff("yyyy",strFileDateLastAccessed,Now)
' ModifiedDiff = DateDiff("yyyy",strFileDateLastModified,Now)
' MaxTime = 3 'Max time in years. For days change "yyyy" to "d"
' If (CreatedDiff >= MaxTime) AND (AccessedDiff >= MaxTime) AND (ModifiedDiff >= MaxTime) Then
MyFile.Write strFilePath & "~|~" &_
strFileName & "~|~" &_
strFileSize & "~|~" &_
strFileType & "~|~" &_
strFileDateCreated & "~|~" &_
strFileDateLastAccessed & "~|~" &_
strFileDateLastModified & "~|~" &_
strFileOwner & vbCrLf
' End If
End If
Next
ShowSubFolders Subfolder
Next
End Sub
It's a bit difficult to tell you how to do it since you've not provided your full script, as you reference objects that were not instantiated in the code you provided.
Yes you can write each folder's output to a new file as well as free memory. You need to change your script's structure a bit though. I was doing it for you until I came across more undefined objects and gave up, so instead I'll just tell you what to do.
You don't need two subs, just one will do. Here's the outline of the structure:
Dim fso, startfolder
Set fso = CreateObject("Scripting.FileSystemObject")
startfolder = "C:\temp"
GetFileInfo startfolder
Sub GetFileInfo(folderpath)
On Error Resume Next
Dim file, logpath, logfile, folder
logpath = "C:\log\" & fso.GetBaseName(folderpath) & ".log" ' C:\log folder must exist; but of course edit path and file name conventions as desired
Set logfile = fso.OpenTextFile(logpath, 2, True)
If Err Then EchoAndQuit "Failed to create log " & logpath & ": " & Err.Description
' Write the file info in current folder
For Each file In fso.GetFolder(folderpath).Files
logfile.WriteLine file.Name ' file/security info
Next
'Set x = Nothing (Set objects instantiated in this sub to nothing to release memory)
' Now the recursive bit
For Each folder In fso.GetFolder(folderpath).SubFolders
GetFileInfo(folder.Path)
Next
On Error GoTo 0
End Sub
Sub EchoAndQuit(msg)
MsgBox msg, 4096 + 16, "Failed"
WScript.Quit
End Sub
One problem with this is you'll get an access denied error if you have multiple folder with the same name - I'll leave it to you to work out some check/naming convention to avoid this. (You could get around it by setting logfile = nothing, but you'll overwrite existing log files if there are multiple folders with the same name. So that's something you could work out, some log file check/naming convention to get around the duplicate name issue, then you could destroy the object if you wanted.)

error resume next in vbs

I wan't to upload periodically a file to samba share. My script works perfectly, but it crashes if samba share is not accessible (i.e. server or network is down). It is possible to run my vbs script silently ( to ignore errors ) ?
this is my piece of code:
while True
On Error resume next
NetworkObject.MapNetworkDrive "", ServerShare, False, UserName, Password
Set Directory = FSO.GetFolder(ServerShare)
WScript.Sleep 2000
folderName = "\\10.10.10.10\smb\" & strComputerName
If Not FSO.FolderExists(folderName) Then
FSO.CreateFolder folderName
End If
folderName = "\\10.10.10.10\smb\" & strComputerName & "\" & Year(now)
If Not FSO.FolderExists(folderName) Then
FSO.CreateFolder folderName
End If
folderName = "\\10.10.10.10\smb\" & strComputerName & "\" & Year(now) & "\" & Month(now)
If Not FSO.FolderExists(folderName) Then
FSO.CreateFolder folderName
End If
folderName = "\\10.10.10.10\smb\" & strComputerName & "\" & Year(now) & "\" & Month(now) & "\" & Day(now)
If Not FSO.FolderExists(folderName) Then
FSO.CreateFolder folderName
End If
DestinationFile = folderName & "\" & hour(now) & "_" & minute(now) & "_" &second(now) & ".png"
fso.CopyFile SourceFile & "\1.tmp", DestinationFile
WScript.Sleep 2000
fso.DeleteFile(SourceFile & "\1.tmp")
WScript.Sleep 2000
wend
I tried to use "On Error resume next" statement, but it crashes anyway.
I dont think having an on error resume next statement is the best option, and i believe this is bad coding practice. I would consider doing something like this, which will improve coding and stop repeating code.
NetworkObject.MapNetworkDrive "", ServerShare, False, UserName, Password
Set Directory = FSO.GetFolder(ServerShare)
WScript.Sleep 2000
folderName = "\\10.10.10.10\smb\" & strComputerName
Call Check_Folder(folderName)
folderName = "\\10.10.10.10\smb\" & strComputerName & "\" & Year(now)
Call Check_Folder(folderName)
'add in the rest of the foldernames and call check_folder lines
DestinationFile = folderName & "\" & hour(now) & "_" & minute(now) & "_" &second(now) & ".png"
fso.CopyFile SourceFile & "\1.tmp", DestinationFile
WScript.Sleep 2000
fso.DeleteFile(SourceFile & "\1.tmp")
WScript.Sleep 2000
'Sub to increase code reuse
Sub Check_Folder(folderName)
'Begin error checking
On error resume next
If Not FSO.FolderExists(folderName) Then
FSO.CreateFolder folderName
End If
If err.number <> 0 Then
'There is an error here, do something or nothing
End If
'Clear error
On error go to 0
End Sub

Convert A Robocopy Command to VB Script

I used to use a line in Robocopy that would allow me to copy all folders in a folder INCLUDING the parent folder, I.E all files/folders in the Blackberry folder INCLUDING the Blackberry folder itself, else without it it would just copy the files within and dump them in the backup location...
The code used was;
for %%a in ("%source%") do SET destination="Backups\%date%\%%~nxa"
Now in VB Script I've got;
sSource = Chr(34) & objFolder.self.Path & Chr(34) & " "
So how would I go about having VB Script (which still calls Robocopy) use the above so that when it backs up it will include the PARENT folder as well?
This was the code I had; Converting Robocopy Batch To VB Script
Thanks in advance!
EDIT: The current content of my script file;
Dim BrowseBackupSource
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please browse to the folder you would like to backup.", 1, "C:\")
If objFolder Is Nothing Then
Wscript.Quit
End If
wscript.Echo "folder: " & objFolder.title & " Path: " & objFolder.self.path
Dim BrowseBackupLocation
Set objShell = CreateObject("Shell.Application")
Set objDest = objShell.BrowseForFolder(0, "Please browse to the folder you would like to save the backup to.", 1, "C:\")
If objDest Is Nothing Then
Wscript.Quit
End If
wscript.Echo "folder: " & objDest.title & " Path: " & objDest.self.path
sCmd = "%windir%\System32\Robocopy.exe "
sDate = Day(Now) & "-" & Month(Now) & "-" & Year(Now)
sTime = Hour(Now) & "-" & Minute(Now) & "-" & Second(Now)
sSource = Chr(34) & objFolder.self.Path & Chr(34) & " "
sDestination = Chr(34) & objDest.self.Path & Chr(34) & " "
sSwitches = "/E /Log:"& sTime &".txt"
Set objShell = CreateObject("Wscript.Shell")
objShell.Run(sCmd & sSource & sDestination & sSwitches)
Well, if you need the path to the parent folder to set as root of copy:
dim parentFolderPath
parentFolderPath = WScript.CreateObject("Scripting.FileSystemObject").GetFolder(objFolder.self.Path).ParentFolder.Path
EDIT
You need the name of the selected source directory added to the path of the selected destination so
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
sSourceFolderName = fso.GetFolder(objFolder.self.Path).Name
sDestination = Chr(34) & objDest.self.Path & "\" & sSourceFolderName & Chr(34)
Robocopy will handle the target directory creation
If you want to create a copy of a particular folder for backup, why don't you simply copy that folder to the backup destination and be done with it?
Set fso = CreateObject("Scripting.FileSystemObject")
Set app = CreateObject("Shell.Application")
dst = "C:\backups\" & Year(Now) & "\" & Month(Now) & "\" & Day(Now)
CreatePath dst
Set fldr = app.BrowseForFolder(0, "Example", 1, "c:\Programs")
fso.CopyFolder fldr.Self.Path, dst & "\", True
Sub CreatePath(p)
If Not fso.FolderExists(p) Then
CreatePath fso.GetParentFolderName(p)
fso.CreateFolder p
End If
End Sub

Script timesout in the middle of execution

I wrote a small script to help re-organize my .mp3 collection. When I run this script, sometimes it will process several thousand files till it would hit an error condition (normally a move of a file that had a special character in its name/path that I hadn't counted for), but it would often exit the script with the text
Script execution time was exceeded on script "C:\DevSpace\mp3move.vbs".
Script execution was terminated.
Im not sure why this is happening. In an effort to figure out where this occured I added several msgbox lines, and what I found is that a msgbox would popup, but then it would auto-close very quickly.
Here is the code - i appoligize for not getting the formatting correctly in the forum
'Takes all .MP3 files in the source dir, reads the Artist tag associated with that file
'Checks for a dir named after the artist in the destination dir
'If the folder artist/album does not exists, it will create it
'Then move the .mp3 file to the dest dir
Dim oAppShell, oFSO, oFolder, oFolderItems
Dim strPath, i
Dim sInfo
iDebug=0
sInfo = "Item Description"
strPath = "K:\_preprocess"
sDestination = "K:\Music"
Set oAppShell = CreateObject("Shell.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
If not oFSO.FolderExists(strPath) Then
WScript.Echo "Folder " & strPath & " is inaccessble"
End If
Set oFolder = oAppShell.NameSpace(strPath)
Set oFolderItems = oFolder.Items()
sCreate = ""
sExist = ""
sMoved = ""
If (not oFolderItems is nothing) Then
if oFolderItems.Count = 0 then
Wscript.echo "no files found in this folder: " & strPath
WScript.Quit
end If
If iDebug = 1 Then
i = oFolderItems.count
WScript.Echo i
End If
For Each oItem in oFolderItems
If iDebug = 1 Then
i = i - 1
End If
If oItem.Type = "MP3 audio file (mp3)" or oItem.Type = "MP3 Format Sound (.mp3)"_
Or oItem.Type = "Windows Media Audio file" or oItem.Type = "MP3 Format Sound" then
'get artist name
sArtist = oFolder.GetDetailsOf(oItem, 20)
If iDebug = 1 Then
MsgBox oItem.name
MsgBox sArtist
End If
'if 'The Beatles' change to 'Beatles, the'
If InStr(LCase(sArtist),"the") = 1 Then
sArtist = Mid(sArtist,5) & ", the"
End If
'remove \ from band name
If InStr(sArtist,"\") > 0 Then
sArtist = Replace(sAlbum,"\","")
End If
If InStr(sArtist,"/") > 0 Then
sArtist = Replace(sAlbum,"/","")
End If
If iDebug = 1 Then
MsgBox sArtist
End If
'if folder does not exist create
'MsgBox sDestination & "\" & sArtist
If oFSO.FolderExists(sDestination & "\" & sArtist) Then
'MsgBox "EXIST"
sExist = sExist & sDestination & "\" & sArtist & " exists" & vbCrLf
Else
'MsgBox "CREATE " & sDestination & "\" & sArtist
rtn = oFSO.CreateFolder(sDestination & "\" & sArtist)
sCreate = sCreate & sDestination & "\" & sArtist & " created" & vbCrLf
End If
'get album name
sAlbum = oFolder.GetDetailsOf(oItem, 14)
'remove special characters from album name
If InStr(sAlbum,":") > 0 Then
sAlbum = Replace(sAlbum,":","")
End if
If InStr(sAlbum,"?") > 0 Then
sAlbum = Replace(sAlbum,"?","")
End If
If InStr(sAlbum,"...") > 0 Then
sAlbum = Replace(sAlbum,"...","")
End If
If InStr(sAlbum,"/") > 0 Then
sAlbum = Replace(sAlbum,"/","")
End If
If InStr(sAlbum,"\") > 0 Then
sAlbum = Replace(sAlbum,"\","")
End If
'create dir artist/album
If oFSO.FolderExists (sDestination & "\" & sArtist & "\" & sAlbum) Then
'sExist = sExist & sDestination & "\" & sArtist & sAlbum & " exists" & vbCrLf
Else
'MsgBox sDestination & "\" & sArtist & "\" & sAlbum
rtn = oFSO.CreateFolder (sDestination & "\" & sArtist & "\" & sAlbum)
'sCreate = sCreate & sDestination & "\" & sArtist & " created" & vbCrLf
End If
'move file
sSource = strPath & "\" & oItem.name & ".mp3"
sDest = sDestination & "\" & sArtist & "\" & sAlbum & "\"
If iDebug=1 Then
MsgBox sSource & vbCrLf & sDest
End If
If oFSO.FileExists (sSource) Then
oFSO.MoveFile sSource, sDest
'sMoved = sMoved & sSource & " moved to " & sDest & vbcrlf
'MsgBox smoved
Else
MsgBox sSource & " not moved"
End If
End If
If iDebug = 1
WScript.Sleep 1000
WScript.Echo i
End If
Next
If iDebug=1
WScript.Echo i
End if
'MsgBox sCreate
'MsgBox sExist
'MsgBox sMoved
End If
You should set the WScript.Timeout property to a higher value.
See example here
The problem existed with my input files. Some of the .mp3 files I was using to test with had non-ascii characters in the tags, and that caused the program to freeze

Resources