Script timesout in the middle of execution - vbscript

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

Related

Problem using windows path having space in it

I have created a VB script that I am calling from my batch file on Windows 10. The script is something like this:
Set startupShortcut = sh.CreateShortcut("%ProgramData%\Microsoft\Windows\Start Menu\Programs\MyApplication.lnk")
startupShortcut.IconLocation = "C:\Users\MyUser\MyApplication\resources\MyApplication.ico"
startupShortcut.TargetPath = "C:\Users\MyUser\MyApplication\MyApplication-1.4.4.jar"
startupShortcut.WorkingDirectory = "C:\Users\MyUser\MyApplication"
startupShortcut.Save
The shortcut path here has a space in "Start Menu" string. Running it does not create any shortcut at the mentioned path, but when I use a path without shortcut for eg. Desktop, it works fine.
I really need help to understand how I can use paths having space in them.
Here is a subroutine example that can be used for creating a shortcut :
Option Explicit
Const Title = "Create a shortcut for the current vbscript or any other application with arguments using an array"
Call RunAsAdmin()
Create_Shortcut Array("Desktop","Recent","shell:Recent")
Create_Shortcut Array("Desktop","User profile","%userprofile%")
Create_Shortcut Array(_
"Desktop",_
"NetworkDiagnostics",_
"%SystemRoot%\system32\msdt.exe",_
"-skip TRUE -path %Windir%\diagnostics\system\networking -ep NetworkDiagnosticsPNI",_
"%SystemRoot%\system32\msdt.exe,0",_
"Network Diagnostics to fix connections problems",_
"CTRL+ALT+D"_
)
'-------------------------------------------------------------------------------------------------------
Sub Create_Shortcut(rArgs)
Dim objShell,objShortCut,ObjShortcutPath,ShortcutName,ShortcutPath,ShortcutLocation
Dim TargetPath,Arguments,IconLocation,Description,HotKey
Set objShell = CreateObject("WScript.Shell")
If UBound(rArgs) > 1 Then
ShortcutLocation = cstr(rArgs(0))
ShortcutPath = objShell.SpecialFolders(ShortcutLocation)
ShortcutName = cstr(rArgs(1))
Set objShortCut = objShell.CreateShortcut(ShortcutPath & "\" & ShortcutName & ".lnk")
TargetPath = objShell.ExpandEnvironmentStrings(rArgs(2))
objShortCut.TargetPath = TargetPath
If ShortcutPath = "" Then
MsgBox "Error The Shortcut Path Does Not Exsists On Your System."_
,vbCritical+vbSystemModal,Title
wscript.quit(1)
End If
End If
If UBound(rArgs) > 2 Then
Arguments = cstr(rArgs(3))
objShortCut.Arguments = Arguments
End If
If UBound(rArgs) > 3 Then
IconLocation = cstr(rArgs(4))
ObjShortCut.IconLocation = IconLocation
End If
If UBound(rArgs) > 4 Then
Description = cstr(rArgs(5))
ObjShortCut.Description = Description
End If
If UBound(rArgs) > 5 Then
HotKey = cstr(rArgs(6))
ObjShortCut.HotKey = HotKey
End If
objShortCut.Save
On Error Resume Next
If Err.Number <> 0 Then
ShowError()
Else
objShell.Popup "The Shortcut "& chr(34) & ShortcutName & chr(34) &" is created Successfully !"& vbcrlf &_
"On " & chr(34) & ShortcutPath & chr(34),5,Title,vbInformation+vbSystemModal
End If
End Sub
'-------------------------------------------------------------------------------------------------------
Sub ShowError()
ErrDetail = "Description : " & Err.Description & vbCrlf & _
"Error number : " & Err.Number & vbCrlf & _
"Error source : " & Err.Source
MsgBox ErrDetail,vbCritical+vbSystemModal,Title
Err.clear
End Sub
'-------------------------------------------------------------------------------------------------------
Sub RunAsAdmin()
If Not WScript.Arguments.Named.Exists("elevate") Then
CreateObject("Shell.Application").ShellExecute WScript.FullName _
, chr(34) & WScript.ScriptFullName & chr(34) & " /elevate", "", "runas", 1
WScript.Quit
End If
End Sub
'-------------------------------------------------------------------------------------------------------
I used & to connect 2 paths with spaces and it worked well for me:
startupShortcutPath = "C:\ProgramData\Microsoft\Windows\" & "\Start Menu\Programs\MyApplication\MyApplication.lnk"

Adding RecordID in front of copied file

I have a code that copies a file from one location to another. What I would like it that when the file is copied, the recordID is placed in front of the file name (example: 150-FirstName). Here is the code I'm working with:
Private Sub cmd_LocateFile_Click()
On Error GoTo Error_Handler
Dim sFile As String
Dim sFolder As String
sFile = FSBrowse("", msoFileDialogFilePicker, "All Files (*.*),*.*")
If sFile <> "" Then
sFolder = Application.CodeProject.path & "\" & sAttachmentFolderName & "\"
If FolderExist(sFolder) = False Then MkDir (sFolder)
If CopyFile(sFile, sFolder & GetFileName(sFile)) = True Then
Me.FullFileName = sFolder & GetFileName(sFile)
Else
End If
End If
Error_Handler_Exit:
On Error Resume Next
Exit Sub
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & sModName & "\cmd_LocateFile_Click" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Sub
Try with:
Dim Id As Long
Dim sTarget As String
Id = YourRecordID ' Set current record id.
sTarget = sFolder & CStr(Id) & "-" & GetFileName(sFile)
' Replace your current If-Then-Else-End If block.
If CopyFile(sFile, sTarget)) = True Then
Me!FullFileName.Value = sTarget
End If

Recursive folder synchronization using VBScript (Mirror Folders)

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

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

VB script to check if the file size has been increased from the previous check

i need a VB script that checks the file size and captures it and in the next check it compares it with the previous check. If the size has increased, it should prompt File size increased.
You can give a try to this vbscript :
Option Explicit
const bytesToKb = 1024
Dim strFile,Title
Title = "The File Size Checker by Hackoo 2015"
strFile = "C:\test.txt"
Call CheckSize(strFile)
'*****************************************************************
Sub CheckSize(File)
Dim ws,fso,objFile,ReadSize,WriteSize,MySizeFile,Temp,LastSize
Set ws = CreateObject("wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Temp = ws.ExpandEnvironmentStrings("%Temp%")
MySizeFile = Temp & "\MyFileSize.txt"
If Not fso.FileExists(MySizeFile) Then
Set WriteSize = fso.OpenTextFile(MySizeFile,2,True)
set objFile = fso.GetFile(strFile)
WriteSize.Write objFile.Size
End If
Set ReadSize = fso.OpenTextFile(MySizeFile,1)
LastSize = ReadSize.readall
set objFile = fso.GetFile(strFile)
If CLng(objFile.Size) = CLng(LastSize) Then
MsgBox "There is no change on file size : " & CLng(LastSize) & " bytes" & vbcr &_
"Size in Kb : "& CLng(objFile.Size/bytesToKb) & " Kb",VbInformation,Title
else
Set WriteSize = fso.OpenTextFile(MySizeFile,2,True)
MsgBox "Last File Size is : " & CLng(LastSize) & " bytes" & vbcr &_
"New File Size is : " & objFile.Size & " bytes" & vbcr &_
"Size in Kb : "& CLng(objFile.Size/bytesToKb) & " Kb",VbExclamation,Title
WriteSize.Write objFile.Size
end if
End Sub
'*******************************************************************
I improved a little this script to check every minute in a loop if the size was changed or not, if yes it will popup a msgbox to notify you that size was changed, if no, it sleeps for 1 minute and it checks it again.
Option Explicit
const bytesToKb = 1024
Dim strFile,Title
Title = "The File Size Checker by Hackoo 2015"
strFile = "C:\test.txt"
If AppPrevInstance() Then
MsgBox "There is an existing proceeding",VbExclamation,"There is an existing proceeding"
WScript.Quit
Else
Do
Call CheckSize(strFile)
Loop
End If
'*****************************************************************
Sub CheckSize(File)
Dim ws,fso,objFile,ReadSize,WriteSize,MySizeFile,Temp,LastSize
Set ws = CreateObject("wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Temp = ws.ExpandEnvironmentStrings("%Temp%")
MySizeFile = Temp & "\MyFileSize.txt"
If Not fso.FileExists(MySizeFile) Then
Set WriteSize = fso.OpenTextFile(MySizeFile,2,True)
set objFile = fso.GetFile(strFile)
WriteSize.Write objFile.Size
End If
Set ReadSize = fso.OpenTextFile(MySizeFile,1)
LastSize = ReadSize.readall
set objFile = fso.GetFile(strFile)
If CLng(objFile.Size) = CLng(LastSize) Then
Call Pause(1) 'To sleep for 1 minute
else
Set WriteSize = fso.OpenTextFile(MySizeFile,2,True)
MsgBox strFile & vbcr &"Last Size is : " & CLng(LastSize) & " bytes" & vbcr &_
"New Size is : " & objFile.Size & " bytes" & vbcr &_
"Size in Kb : "& CLng(objFile.Size/bytesToKb) & " Kb",VbExclamation,Title
WriteSize.Write objFile.Size
end if
End Sub
'**************************************************************************
'Checks whether a script with the same name as this script is already running
Function AppPrevInstance()
With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
With .ExecQuery("SELECT * FROM Win32_Process WHERE CommandLine LIKE " & CommandLineLike(WScript.ScriptFullName) & _
" AND CommandLine LIKE '%WScript%' OR CommandLine LIKE '%cscript%'")
AppPrevInstance = (.Count > 1)
End With
End With
End Function
'**************************************************************************
Function CommandLineLike(ProcessPath)
ProcessPath = Replace(ProcessPath, "\", "\\")
CommandLineLike = "'%" & ProcessPath & "%'"
End Function
'**************************************************************************
Sub Pause(Minutes)
Wscript.Sleep(Minutes*1000*60)
End Sub
'**************************************************************************
Here is another approch that can monitor and check more than one file in changing size :
Option Explicit
const bytesToKb = 1024
Dim Title,strFile,ListFiles
Title = "The File Size Checker by Hackoo 2015"
ListFiles = Array("c:\test.txt","E:\My test dossier\t.txt","E:\My test dossier\TmpLog.txt")
If AppPrevInstance() Then
MsgBox "There is an existing proceeding",VbExclamation,"There is an existing proceeding"
WScript.Quit
Else
Do
Call Main(ListFiles)
Call Pause(1) 'To Sleep for 1 minute
Loop
End If
'******************************************************************
Sub Main(strFilesPaths)
Dim strFile
For Each strFile In strFilesPaths
CheckSize(strFile)
Next
End Sub
'******************************************************************
Function StripPath(Path)
Dim arrStr : arrStr = Split(Path,"\")
StripPath = arrStr(UBound(arrStr))
End Function
'*****************************************************************
Sub CheckSize(File)
Dim ws,fso,objFile,ReadSize,WriteSize,MySizeFile,Temp,LastSize,strFile
Set ws = CreateObject("wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Temp = ws.ExpandEnvironmentStrings("%Temp%")
For Each strFile In ListFiles
MySizeFile = Temp & "\" & StripPath(strFile)
If Not fso.FileExists(MySizeFile) Then
Set WriteSize = fso.OpenTextFile(MySizeFile,2,True)
set objFile = fso.GetFile(strFile)
WriteSize.Write objFile.Size
End If
Set ReadSize = fso.OpenTextFile(MySizeFile,1)
LastSize = ReadSize.readall
set objFile = fso.GetFile(strFile)
If CLng(objFile.Size) = CLng(LastSize) Then
else
Set WriteSize = fso.OpenTextFile(MySizeFile,2,True)
MsgBox strFile & vbcr &"Last Size is : " & CLng(LastSize) & " bytes" & vbcr &_
"New Size is : " & objFile.Size & " bytes" & vbcr &_
"Size in Kb : "& CLng(objFile.Size/bytesToKb) & " Kb",VbExclamation,Title
WriteSize.Write objFile.Size
end if
Next
End Sub
'**************************************************************************
'Checks whether a script with the same name as this script is already running
Function AppPrevInstance()
With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
With .ExecQuery("SELECT * FROM Win32_Process WHERE CommandLine LIKE " & CommandLineLike(WScript.ScriptFullName) & _
" AND CommandLine LIKE '%WScript%' OR CommandLine LIKE '%cscript%'")
AppPrevInstance = (.Count > 1)
End With
End With
End Function
'**************************************************************************
Function CommandLineLike(ProcessPath)
ProcessPath = Replace(ProcessPath, "\", "\\")
CommandLineLike = "'%" & ProcessPath & "%'"
End Function
'**************************************************************************
Sub Pause(Minutes)
Wscript.Sleep(Minutes*1000*60)
End Sub
'**************************************************************************

Resources