VB Script Error - Worked before but now not confusingly - vbscript

i am getting a error
The VB file reads col1 and finds the matching image name in the directory and the renames that file to col2 it produces a report to show what images haven't been renamed and placed the ones that have in a folder called rename
i have attached the code so you can see
strDocMap = "C:\img\DocMap.xlsx"
strInputFolder = "C:\img\"
strOutputFolder = "C:\img\renamed\"
strLogFile = "C:\img\RenamingLog.txt"
strPattern = "\d{5}"
Set regExpression = New RegExp
With regExpression
.Global = True
.IgnoreCase = True
.Pattern = strPattern
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Const xlUp = -4162
Const xlFormulas = -4123
Const xlPart = 2
Const xlByRows = 1
Const xlNext = 1
Set objWB = objExcel.Workbooks.Open(strDocMap, False, True)
Set objSheet = objWB.Sheets(1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Right(strInputFolder, 1) <> "\" Then strInputFolder = strInputFolder & "\"
If Right(strOutputFolder, 1) <> "\" Then strOutputFolder = strOutputFolder & "\"
If objFSO.FolderExists(strOutputFolder) = False Then objFSO.CreateFolder strOutputFolder
Set objLog = objFSO.CreateTextFile(strLogFile, True)
objLog.WriteLine "Script started " & Now
objLog.WriteLine "Enumerating files in folder: " & strInputFolder
objLog.WriteLine "Renaming files to folder: " & strOutputFolder
objLog.WriteLine String(80, "=")
For Each objFile In objFSO.GetFolder(strInputFolder).Files
Set colMatches = regExpression.Execute(objFile.Name)
If colMatches.Count > 0 Then
If colMatches.Count = 1 Then
For Each objMatch In colMatches
strOldNum = objMatch.Value
Set objCell = objSheet.Cells.Find(strOldNum, objSheet.Range("A1"), xlFormulas, xlPart, xlByRows, xlNext, False, False)
If Not objCell Is Nothing Then
strNewNum = objCell.Offset(0, 1).Value
If strNewNum <> "" Then
strNewPath = strOutputFolder & strNewNum & "." & objFSO.GetExtensionName(objFile.Path)
' Check if a file already exists without the appended letter
blnValid = True
If objFSO.FileExists(strNewPath) = True Then
blnValid = False
' Start at "a"
intLetter = 97
strNewPath = strOutputFolder & strNewNum & Chr(intLetter) & "." & objFSO.GetExtensionName(objFile.Path)
Do While objFSO.FileExists(strNewPath) = True
intLetter = intLetter + 1
strNewPath = strOutputFolder & strNewNum & Chr(intLetter) & "." & objFSO.GetExtensionName(objFile.Path)
If intLetter > 122 Then Exit Do
Loop
If intLetter <= 122 Then blnValid = True
End If
If blnValid = True Then
objLog.WriteLine "Renaming " & objFile.Name & " to " & Mid(strNewPath, InStrRev(strNewPath, "\") + 1)
objFSO.MoveFile objFile.Path, strNewPath
Else
objLog.WriteLine "Unable to rename " & objFile.Name & ". Letters exhausted."
End If
End If
End If
Next
Else
objLog.WriteLine objFile.Name & " contains " & colMatches.Count & " matches. Manual adjustment required."
End If
End If
Next
objLog.WriteLine String(80, "=")
objLog.WriteLine "Script finished " & Now
objWB.Close False
objExcel.Quit
objLog.Close
MsgBox "Done"
Thanks
Jack

If line 68
objLog.WriteLine objFile.Name & " contains " & colMatches.Count & " matches. Manual adjustment required."
is really the culprit, I would argue:
The objects objLog, objFile, and colMatches were used before -
acquittal
The methods .WriteLine, .Name, and .Count look good - acquittal
Concatenation (&) should work on string literals and not
null/empty/nothing elements - acquittal
By elimination: objFile.Name contains a funny letter (not
convertable to 'ASCII'). Easy check: Replace "objFile.Name" with a
string literal.
Evidence
Dim s
For Each s In Array(Empty, Null, ChrW(1234))
On Error Resume Next
goFS.CreateTextFile("tmp.txt", True).WriteLine s
WScript.Echo Err.Description
On Error GoTo 0
Next
output:
====================================
Type mismatch
Invalid procedure call or argument
====================================

Related

Unable to pin .exe with parameter to Taskbar/Start Menu

I'm trying to write a .vbs script to pin an .exe to my taskbar and start menu.
However, the .exe will only run if I pass in a package parameter.
Here's the target of the shortcut:
"C:\Program Files (x86)\Launch\AppLauncher.exe" package=TEST
I currently have the following for code but I get the error message attached when I try and run it.
Const a = """"
arrActions = Array( _
"pin", "Start Menu", """C:\Program Files (x86)\Launch\AppLauncher.exe"" package=TEST", _
"pin", "Taskbar", """C:\Program Files (x86)\Launch\AppLauncher.exe"" package=TEST" _ )
For intAction = 0 To (UBound(arrActions) - 2) Step 3
arrFileNames = Array(arrActions(intAction + 2))
'strMode can be "Pin" or "Unpin"
strMode = arrActions(intAction)
'strLocation can be "Start Menu" or "Taskbar" or "Both"
strLocation = arrActions(intAction + 1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShellApp = CreateObject("Shell.Application")
Set objShell = CreateObject("WScript.Shell")
If LCase(strLocation) = "both" Then
arrLocations = Array("Start Menu", "Taskbar")
Else
arrLocations = Array(strLocation)
End If
For Each strLocation In arrLocations
If LCase(strMode) <> "pin" And LCase(strMode) <> "unpin" Then
WScript.Echo "Mode is incorrect. Please set to ""pin"" or ""unpin""."
WScript.Quit
ElseIf LCase(strLocation) <> "start menu" And LCase(strLocation) <> "taskbar" Then
WScript.Echo "Location is incorrect. Please set to ""Start Menu"" or ""Taskbar""."
WScript.Quit
Else
strMode = LCase(strMode)
If strMode = "pin" Then
strVerb = LCase(strMode & " to " & strLocation)
strMessage = " has been " & strMode & "ned to the " & strLocation & "."
ElseIf strMode = "unpin" Then
strVerb = LCase(strMode & " from " & strLocation)
strMessage = " has been " & strMode & "ned from the " & strLocation & "."
End If
For Each strFilePath In arrFileNames
If LCase(strFilePath) = "unpin_all" And strMode = "unpin" Then
strPinLocation = objShell.ExpandEnvironmentStrings("%APPDATA%") & _
"\Microsoft\Internet Explorer\Quick Launch\User Pinned\" & _
Replace(strLocation, " ", "") & "\"
For Each objFile In objFSO.GetFolder(strPinLocation).Files
strFullPath = objFile.Path
'Set objFile = objFSO.GetFile(objFile.Path)
Set objFolder = objShellApp.Namespace(objFile.ParentFolder & "\")
Set objFolderItem = objFolder.ParseName(objFile.Name)
Set colVerbs = objFolderItem.Verbs
For Each objVerb In colVerbs
If LCase(Replace(objVerb.name, "&", "")) = strVerb Then
objVerb.DoIt
WScript.Echo strFullPath & strMessage
End If
Next
Next
Else
If objFSO.FileExists(strFilePath) = True Then
Set objFile = objFSO.GetFile(strFilePath)
Set objFolder = objShellApp.Namespace(objFile.ParentFolder & "\")
Set objFolderItem = objFolder.ParseName(objFile.Name)
Set colVerbs = objFolderItem.Verbs
blnOptionFound = False
For Each objVerb In colVerbs
If LCase(Replace(objVerb.name, "&", "")) = strVerb Then
objVerb.DoIt
blnOptionFound = True
End If
Next
If blnOptionFound = True Then
WScript.Echo strFilePath & strMessage
Else
WScript.Echo "Unable to " & strMode & " " & strFilePath & _
" from the " & strLocation & ". The verb does not exist."
End If
Else
WScript.Echo "Could not find " & strFilePath
End If
End If
Next
End If
Next
Next
Error message

Sync outlook messages with vbscript

I have a vbscript that copy's Outlook 2003 messages into a folder in msg format.
The problems are:
I am getting "path too long" errors for some *.msg . I wish to avoid these erros and I don't know how. ' On Error Resume Next is already on the script.
I am getting only inbox messages, but I want all subfolders too;
How can I extract this in *.txt and not in *.msg, in order to become lighter?
Here is my atual script. Thanks for the help!
On Error Resume Next
Dim myNameSpace
Dim ofChosenFolder
Dim myOlApp
Dim myItem
Dim objItem
Dim myFolder
Dim strSubject
Dim strName
Dim strFile
Dim strReceived
Dim strSavePath
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Const olFolderInbox = 6
Set ofChosenFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
strSavePath = "c:\test\" 'OBS! use a \ at the end of the path
i = 1
For each Item in ofChosenFolder.Items
Set myItem = ofChosenFolder.Items(i)
strReceived = ArrangedDate(myitem.ReceivedTime)
' strSubject = myItem.Subject
strSubject = myitem.SenderName & "_" & myitem.Subject
strName = StripIllegalChar(strSubject)
strFile = strSavePath & strReceived & "_" & strName & ".msg"
If Not Len(strfile) > 256 then
myItem.SaveAs strfile, 3
Else
wscript.echo strfile & vbcrlf & "Path and filename too long."
End If
i = i + 1
next
Function StripIllegalChar(strInput)
'***************************************************
'Simple function that removes illegal file system
'characters.
'***************************************************
Set RegX = New RegExp
RegX.pattern = "[\" & chr(34) & "\!\#\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(strInput, "")
Set RegX = nothing
End Function
Function ArrangedDate(strDateInput)
'***************************************************
'This function re-arranges the date data in order
'for it to display in chronilogical order in a
'sorted list in the file system. It also removes
'illegal file system characters and replaces them
'with dashes.
'Example:
'Input: 2/26/2004 7:07:33 AM
'Output: 2004-02-26_AM-07-07-33
'***************************************************
Dim strFullDate
Dim strFullTime
Dim strAMPM
Dim strTime
Dim strYear
Dim strMonthDay
Dim strMonth
Dim strDay
Dim strDate
Dim strDateTime
Dim RegX
If not Left(strDateInput, 2) = "10" Then
If not Left(strDateInput, 2) = "11" Then
If not Left(strDateInput, 2) = "12" Then
strDateInput = "0" & strDateInput
End If
End If
End If
strFullDate = Left(strDateInput, 10)
If Right(strFullDate, 1) = " " Then
strFullDate = Left(strDateInput, 9)
End If
strFullTime = Replace(strDateInput,strFullDate & " ","")
If Len(strFullTime) = 10 Then
strFullTime = "0" & strFullTime
End If
strAMPM = Right(strFullTime, 2)
strTime = strAMPM & "-" & Left(strFullTime, 8)
strYear = Right(strFullDate,4)
strMonthDay = Replace(strFullDate,"/" & strYear,"")
strMonth = Left(strMonthDay, 2)
strDay = Right(strMonthDay,len(strMonthDay)-3)
If len(strDay) = 1 Then
strDay = "0" & strDay
End If
strDate = strYear & "-" & strMonth & "-" & strDay
'strDateTime = strDate & "_" & strTime
strDateTime = strDate
Set RegX = New RegExp
RegX.pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(strDateTime, "-")
Set RegX = nothing
End Function
You need to truncate the file name appropriately (strName)
Move your code that processes a folder into a sub that take fodler that takes folder as parameter and call it for ofChosenFolder as well as all of its child fodlers in the ofChosenFolder.Folders collection.
You are calling SaveAs..., 3 - 3 here is olMsg. Specify olTxt (= 0).
Off the top of my head:
Const olFolderInbox = 6
Set ofChosenFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
trSavePath = "c:\test\"
ProcessFolder ofChosenFolder, trSavePath
sub ProcessFolder(folder, path)
For each Item in folder.Items
strReceived = ArrangedDate(Item.ReceivedTime)
strSubject = Item.SenderName & "_" &Item .Subject
strName = StripIllegalChar(strSubject)
strFile = strSavePath & strReceived & "_" & strName & ".msg"
If Not Len(strfile) > 256 then
Item.SaveAs strfile, 3
Else
wscript.echo strfile & vbcrlf & "Path and filename too long."
End If
next
for each subfolder in folder.Folders
ProcessFolder(subfolder, trSavePath & subfolder.Name & "\"
next
end sub

VB script to scan latest log file for errors

I have a VB script which scans the mentioned log file for errors and sends a notification through an email.
How can I scan the latest log file in the folder? For example, Filename1.070615 (Filename1.mmddyy) is a log file. After a certain size, the logfile switches to new file with the same name but different date: Filename1.070615.
cdoSendUsingPort = 2, _
Const ForReading = 1
Dim intStartAtLine, strFileCreateddate, i, strResults, strTextToScanFor, bStartFromScratch
Dim strLastCheckedFor, strArrayToString, strSubject, strMailFrom, strMailTo
strMailto = "<Emailaddress>"
strMailFrom = "<FromAddress>"
strSubject = "Log scanner"
strSMTPServer = "x.x.x.x"
FileToRead = "D:\LOG\filename1.mmddyy"
arrTextToScanFor = Array("error","another thing")
Set WshShell = WScript.CreateObject("WScript.Shell")
searchkey = replace(replace(filetoread,":",""),"\","_")
On Error Resume Next
strLastFileCheckedCreateDate = WshShell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CreateDate")
strLastFileLastLineChecked = WshShell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastLineChecked")
strLastCheckedFor = WshSHell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CheckForString")
iLastCheckedLine = WshSHell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastLineChecked")
On Error GoTo 0
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set varFile = objFSO.GetFile(FileToRead)
arrLastCheckedForText = split(strLastCheckedFor,",")
strFileCreateDate = varfile.datecreated
strFileModifiedDate = varfile.datelastmodified
sStatus = "<li>Using mail server: " & strSMTPServer & "</li><li>Running from: " & wscript.scriptfullname & "</li>"
Set objTextFile = objFSO.OpenTextFile(FileToRead, ForReading)
objTextFile.ReadAll
iLineCount = objTextFile.Line
objTextFile.close
If strLastCheckedFor = "" Then
bStartFromScratch = true
sStatus = sStatus & "<li>First run of script against string search</li>" & vbcrlf
ElseIf ubound(arrTextToScanFor) <> ubound(arrLastCheckedForText) Then
bStartFromScratch = true
sStatus = sStatus & "<li>Count of string search criteria has changed</li>" & vbcrlf
Else
For each strItem in arrTextToScanFor
Else
bStartFromScratch = true
'MsgBox strResults
End If
If bStartFromScratch = true Then
sStatus = sStatus & "<li>String search criteria does not match prior search</li>" & vbcrlf
End If
Next
End If
If cint(iLineCount) < cint(iLastCheckedLine) Then
bStartFromScratch = true
sStatus = sStatus & "<li>Last line checked (" & iLastCheckedLine & ") is greater than total line count (" & iLineCount & ") in file</li>"
End If
If CStr(strFileCreateDate) = CStr(strLastFileCheckedCreateDate) and bStartFromScratch <> true Then
intStartAtLine = strLastFileLastLineChecked
If bStartFromScratch <> true then
sStatus = sStatus & "<li>Continuing search from line " & intStartAtLine & "</li>" & vbcrlf
End If
ElseIf strFileCreateDate <> strLastFileCheckedCreateDate or bStartFromScratch = true Then
intStartAtLine = 0
If bStartFromScratch <> true then
sStatus = sStatus & "<li>File created date has changed, starting search from line 0</li>" & vbcrlf
End If
End If
i = 0
Dim strNextLine
For each strItem in arrTextToScanFor
strArrayToString = strArrayToString & delim & strItem
delim = ","
Next
Set objTextFile = objFSO.OpenTextFile(FileToRead, ForReading)
Do While objTextFile.AtEndOfStream <> True
If i < CInt(intStartAtLine) Then
objTextFile.skipline
Else
'MsgBox i
strNextLine = objTextFile.Readline
For each strItem in arrTextToScanFor
If InStr(LCase(strNextLine),LCase(strItem)) Then
strResults = "<span style='font-family:courier-new;color:#696969'><span style='font-weight:bold;background-color:#BEF3F3'>Line " & i & ":</span> " & replace(lcase(strNextLine),lcase(strItem),"<span style='background-color:#FFFF81'>" & strItem & "</span>") & "</span><br>" & vbcrlf & strResults
bSendMail = true
End If
Next
End If
i = i + 1
Loop
objTextFile.close
Set WshShell = CreateObject("WScript.Shell")
'Let's save our settings for next time.
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\FileChecked", FileToRead, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CreateDate", strFileCreateDate, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastLineChecked", i, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastScanned", Now, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CheckForString",strArrayToString, "REG_SZ"
set WshShell = nothing
strFileSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>File path:</td><td>" & FileToRead & "</td></tr>"
strFileCreateDateSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Created date:</td><td>" & strFileCreateDate & "</td></tr>"
strFileModifiedDateSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Modified date:</td><td>" & strFileModifiedDate & "</td></tr>"
strArraySummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Text string(s):</td><td>" & strArrayToString & "</td></tr>"
strFileLineSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Last line checked:</td><td>" & i & "</td></tr>"
strSummary = strFileSummary & strFileCreateDateSummary & strFileModifiedDateSummary & strArraySummary & strFileLineSummary
strBodyContent = "<table style='font-family:calibri;'>" & strSummary & "</table><br><br><span style='font-size:large;'>Entries:</span><br>" & strResults & "<div style='padding-top:30px;font-size:x-small'><br><div style='font-weight:bold;font-family:calibri;color:black;'>Job Details:<ul style='font-weight:normal;font-family:calibri;color:darkgray;'>" & sStatus & "</ul></div></div>"
on error goto 0
'Send the email if need be.
If bSendMail = true Then Call sendmail(strMailFrom,strMailTo,strSubject,strBodyContent)
'------------------------------------------------------------------------
'Function EmailFile - email the warning file
'------------------------------------------------------------------------
Function SendMail(strFrom,strTo,strSubject,strMessage)
Dim iMsg, iConf, Flds
On Error GoTo 0
'// Create the CDO connections.
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
'// SMTP server configuration.
With Flds
.Item(cdoSendUsingMethod) = cdoSendUsingPort
'// Set the SMTP server address here.
.Item(cdoSMTPServer) = strSMTPServer
.Update
End With
'// Set the message properties.
With iMsg
Set .Configuration = iConf
.To = strMailTo
.From = strMailFrom
.Subject = strSubject
.htmlbody = strMessage
End With
'iMsg.HTMLBody = strMessage
'// Send the message.
iMsg.Send ' send the message.
If CStr(err.number) <> 0 Then
Else
End If
End Function
It would be a bit easier if your log files were named filename1.yymmdd.
Nevertheless, we can use a regex to not only verify the filename but also swap the date components to put them in our desired format!
Set re = New RegExp
re.Pattern = "^(filename1\.)(\d{2})(\d{2})(\d{2})$"
Set fso = CreateObject("Scripting.FileSystemObject")
For Each objFile In fso.GetFolder("d:\log").Files
If re.Test(objFile.Name) Then
strCompareName = re.Replace(objFile.Name, "$1$4$2$3")
If strCompareName > strLatest Then strLatest = strCompareName
End If
Next
' Switch the name back...
strLatest = re.Replace(strLatest, "$1$3$4$2")
WScript.Echo "The latest file is: " & strLatest
This line:
strCompareName = re.Replace(objFile.Name, "$1$4$2$3")
changes the format from mmddyy to yymmdd and saves it in a string for comparison.
Once we've finished our comparisons, we just need to take the latest file we found and reverse the process:
strLatest = re.Replace(strLatest, "$1$3$4$2")
to get the original filename back!

VB Script that will manipulate a file name

Ok, like many other people, I am a noob on VB Scripting. What I am trying to do is create a VB Script that will manipulate a file name from Fulton A1032-CCC Adamsville to just A1032-CCC. I have browsed many site trying to find the answer but only came up with on that halfway worked.
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colFiles = objWMIService.ExecQuery _
("ASSOCIATORS OF {Win32_Directory.Name='H:\Darrell 2014 folder\Distview Wiki Revamp\To'} Where " _
& "ResultClass = CIM_DataFile")
For Each objFile In colFiles
strPath = objFile.Drive & objFile.Path
strExtension = objFile.Extension
strFileName = objFile.FileName
If Left(strFileName, 7) = "Fulton " Then
intLength = Len(strFileName)
strFileName = Right(strFileName, intLength - 7)
End If
If Right(strFileName, 10) = " Adamsville" Then
intLength = Len(strFileName)
strFileName = Left(strFileName, intLength - 10)
End If
strNewName = strPath & strFileName & "." & strExtension
errResult = objFile.Rename(strNewName)
Next
Please Help
Why not just use the replace function instead? For example:
Dim fileName As String
fileName = "Fulton A1032-CCC Adamsville"
fileName = Replace(fileName, "Fulton ", "")
fileName = Replace(fileName, " Adamsville", "")
MsgBox fileName
The output is A1032-CCC. This also works if either or both of the search strings don't exist.
Learn to count:
>> WScript.Echo Len(" Adamsville")
>>
11
>>
or write a function:
>> Function endsWith(b, t)
>> endsWith = Right(b, len(t)) = t
>> End Function
>> WScript.Echo CStr(endsWith("Fulton A1032-CCC Adamsville", " Adamsville"))
>>
True
Update wrt downvotes:
As the downvotes indicate that there are at least two people who can't count either:
Option Explicit
Function qq(s) : qq = """" & s & """" : End Function
Dim strFileName : strFileName = "Fulton A1032-CCC Adamsville"
Dim intLength
WScript.Echo 0, qq(strFileName)
' assume the structure of the input data is:
' <todelete+blank><tokeep><blank+todelete>
WScript.Echo 1, qq(Split(strFileName)(1))
' the ot's code 'works' if you count correctly
If Left(strFileName, 7) = "Fulton " Then
intLength = Len(strFileName)
strFileName = Right(strFileName, intLength - 7)
End If
If Right(strFileName, 11) = " Adamsville" Then
intLength = Len(strFileName)
strFileName = Left(strFileName, intLength - 11)
End If
WScript.Echo 2, qq(strFileName)
output:
cscript 25689666.vbs
0 "Fulton A1032-CCC Adamsville"
1 "A1032-CCC"
2 "A1032-CCC"

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