Memory leak with a recursive sub using VBScript - vbscript

I'm creating a script that will allow a user to search within a specified directory with a search term. The script will create a CSV file and then write the base file name, the file size, the last modified date, and the absolute path of files that contain the search term within the file name. However, I'm running into an issue searching subfolders within the folder. The issue is that I'm running out of memory within the subroutine.
Here is the script I've written thus far.
Dim fileCount, searchPath, searchTerm, CheckFile, wholePath
Dim objFSO, objFolder, objFile, objWriteFile
Dim savePath
objCheckFile = "C:\Users\USERFILE\Desktop\Audit.csv"
Const ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Asks for directory to search in
searchPath = InputBox("Please enter the path of the folder you would like to search", "Where am I searching?")
Set objFolder = objFSO.GetFolder(searchPath)
'Asks for the search term to use
searchTerm = InputBox("Please enter the term you would like to search for", "What am I searching?")
If objFSO.FileExists(objCheckFile) Then
WScript.Echo "Please delete the file named Audit.csv before trying again"
Else
Set objWriteFile = objFSO.CreateTextFile("Audit.csv", ForWriting, True)
End If
Set colFiles = objFolder.Files
Set colFolders = objFolder.SubFolders
'Searches for files within the folder and writes to a CSV file
For Each objFile In colFiles
If InStr(LCase(objFSO.GetFileName(objFile)), LCase(searchTerm)) > 0 Then
objWriteFile.Write objFSO.getFileName(objFile) & ", "
objWriteFile.Write objFile.size & ", "
objWriteFile.Write objFile.DateLastModified & ", "
objWriteFile.Write objFSO.getAbsolutePathName(objFolder) & objFSO.getFileName(objFile)
objWriteFile.Writeline
End If
Next
ShowSubFolder objFolder
Sub ShowSubFolder(Folder)
If InStr(LCase(objFSO.GetFileName(objFile)), LCase(searchTerm)) > 0 Then
objWriteFile.Write objFSO.getFileName(objFile) & ", "
objWriteFile.Write objFile.size & ", "
objWriteFile.Write objFile.DateLastModified & ", "
objWriteFile.Write objFSO.getAbsolutePathName(objFolder) & objFSO.getFileName(objFile)
objWriteFile.Writeline
End If
For Each objSubFolder In colFolders
ShowSubFolder objSubFolder
Next
End Sub

Your recursion never terminates because of this:
Set colFiles = objFolder.Files
Set colFolders = objFolder.SubFolders
'...
ShowSubFolder objFolder
Sub ShowSubFolder(Folder)
'...
For Each objSubFolder In colFolders
ShowSubFolder objSubFolder
Next
End Sub
This is similar to a fork bomb. For each subfolder of objFolder you recurse again into each subfolder of objFolder. And again. And again. And ...
Change your code to this and it should do what you want:
Set colFiles = objFolder.Files
'...
ShowSubFolder objFolder
Sub ShowSubFolder(Folder)
'...
For Each objSubFolder In Folder.SubFolders
ShowSubFolder objSubFolder
Next
End Sub
You may also want to adjust the conditional inside the recursive procedure, because it uses objFile and objFolder that are defined outside the procedure.

Related

VBS to list file names NOT matching given extension

I have been working on the following VBS. This will search a parent folder and all child / subfolders and print any file with the provided extension (doc, docx, msg, ppt, txt) and came up with the following. I am new to VBS but I would like to define the file extensions to IGNORE, listing all others. I have the directory listing of each file type working but I don't want to have to set a NEXT for each file type. I was able to use the <> code in the top section to show all files that don't match an extension using:
If objFSO.GetExtensionName(strFileName) <> "jpg" then
But this doesn't work in the lower part:
if LCase(InStr(1,Files, "jpg")) > 1 then Wscript.Echo Files
I would also like to be able to define multiple file types; like
If objFSO.GetExtensionName(strFileName) <> "jpg" OR "jpeg" OR "tiff"
Lastly I need to output to a text file, not a windows script msg box.
Can anyone help? Sorry for typos or confusion, English is not my first language.
Dim fso
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set FSO = WScript.CreateObject("Scripting.Filesystemobject")
Set f = fso.CreateTextFile("C:\temp\output.txt", 2)
objStartFolder = "C:\Test"
Set objFolder = objFSO.GetFolder(objStartFolder)
Set colFiles = objFolder.Files
For Each objFile in colFiles
strFileName = objFile.Name
If objFSO.GetExtensionName(strFileName) = "x937" then
Wscript.Echo objFile.Name
End If
Next
For Each objFile in colFiles
strFileName = objFile.Name
If objFSO.GetExtensionName(strFileName) = "docx" then
Wscript.Echo objFile.Name
End If
Next
For Each objFile in colFiles
strFileName = objFile.Name
If objFSO.GetExtensionName(strFileName) = "doc" then
Wscript.Echo objFile.Name
End If
Next
For Each objFile in colFiles
strFileName = objFile.Name
If objFSO.GetExtensionName(strFileName) = "txt" then
Wscript.Echo objFile.Name
End If
Next
For Each objFile in colFiles
strFileName = objFile.Name
If objFSO.GetExtensionName(strFileName) = "msg" then
Wscript.Echo objFile.Name
End If
Next
ShowSubfolders objFSO.GetFolder(objStartFolder)
Sub ShowSubFolders(Folder)
For Each Subfolder in Folder.SubFolders
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
for each Files in colFiles
if LCase(InStr(1,Files, "msg")) > 1 then Wscript.Echo Files
next
ShowSubFolders Subfolder
Next
For Each Subfolder in Folder.SubFolders
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
for each Files in colFiles
if LCase(InStr(1,Files, "txt")) > 1 then Wscript.Echo Files
next
ShowSubFolders Subfolder
Next
For Each Subfolder in Folder.SubFolders
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
for each Files in colFiles
if LCase(InStr(1,Files, "ppt")) > 1 then Wscript.Echo Files
next
ShowSubFolders Subfolder
Next
For Each Subfolder in Folder.SubFolders
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
for each Files in colFiles
if LCase(InStr(1,Files, "xls")) > 1 then Wscript.Echo Files
next
ShowSubFolders Subfolder
Next
For Each Subfolder in Folder.SubFolders
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
for each Files in colFiles
if LCase(InStr(1,Files, "doc")) > 1 then Wscript.Echo Files
next
ShowSubFolders Subfolder
Next
End Sub
You can check all of the extensions in one loop:
For Each objFile in colFiles
Dim strFileName : strFileName = objFile.Name
Dim strExtension : strExtension = LCase(objFSO.GetExtensionName(strFileName))
If strExtension <> "txt" And _
strExtension <> "jpg" And _
strExtension <> "msg" And _
strExtension <> "docx" Then
Wscript.Echo objFile.Name
End If
Next
I just put a bunch of random extensions in because it wasn't clear which ones you want to ignore. Make sure you put them all in lowercase so the comparison works because the code converts the actual extension to lowercase.
For exporting the output to a txt file, the below code might work
Function TextFile_Generate()
strFile = "C:\...\ReportName.txt"
strValue = "output text..."
Set objFSO=CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strFile) Then
Set objFile = objFSO.OpenTextFile(strFile,8, True)
Else
Set objFile = objFSO.CreateTextFile(strFile,True)
End If
objFile.Write strValue & vbCrLf
objFile.Close
Set objFile = Nothing
Set objFSO =Nothing
End Function

copying files to another folder and renaming them based on the creation date using vbscript

I'm fairly new to vbscript and programming! As I've already mentioned in the title, I've written (or at least I've tried) a vbscript which should copy and rename all files in C:\test\ and the subfolders of C:\test\ to a another Folder, named C:\test1.
Here's what I've got so far:
Dim objStartFolder, objtargetFolder, objDateCreatedName
Set objFSO = CreateObject("Scripting.FileSystemObject")
objStartFolder = "C:\test"
objtargetFolder = "C:\test1"
Set objFolder = objFSO.GetFolder(objStartFolder)
WScript.Echo objFolder.Path
Set colFiles = objFolder.Files
For Each objFile In colFiles
WScript.Echo objFile.Name
Next
WScript.Echo
ShowSubFolders objFSO.GetFolder(objStartFolder)
Sub ShowSubFolders(Folder)
For Each Subfolder In Folder.SubFolders
WScript.Echo Subfolder.Path
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
For Each objFile In colFiles
Set objDateCreatedName = objFSO.GetFile(objStartFolder)
WScript.Echo objDateCreatedName.DateCreated
WScript.Echo "I'm going to copy " & objFolder.Path & objFile.Name & " to " & objtargetFolder & objtargetFolder & objFile.Name & "."
Next
WScript.Echo
ShowSubFolders Subfolder
Next
End Sub
It would be really nice if you could help me and if you need more Information I'll make sure to deliver them.
If every file should go into the same destination folder you could simply do something like this:
Set fso = CreateObject("Scripting.FileSystemObject")
Function Pad(s)
Pad = Right("00" & s, 2)
End Function
Sub CopyFiles(fldr, dst)
'Copy all files from fldr to destination folder and append the date (in ISO
'format) to the name. Overwrite existing files.
For Each f In fldr.Files
created = Year(f.DateCreated) & "-" & Pad(Month(f.DateCreated)) & "-" & _
Pad(Day(f.DateCreated))
newname = fso.GetBaseName(f) & "_" & created & "." & fso.GetExtensionName(f)
f.Copy fso.BuildPath(dst, newname), True
Next
'Recurse into subfolders.
For Each sf In fldr.SubFolders
CopyFiles sf, dst
Next
End Sub
CopyFiles fso.GetFolder("C:\test"), "C:\test1"

Make log for deleted files using VBScript

The below is my code to delete DAT files.
OPTION EXPLICIT
DIM strExtensionsToDelete,strFolder
DIM objFSO, MaxAge, IncludeSubFolders
' ************************************************************
' Setup
' ************************************************************
' Folder to delete files
strFolder = "E:\test"
' Delete files from sub-folders?
includeSubfolders = true
' A comma separated list of file extensions
' Files with extensions provided in the list below will be deleted
strExtensionsToDelete = "dat"
' Max File Age (in Days). Files older than this will be deleted.
maxAge = 0
' ************************************************************
set objFSO = createobject("Scripting.FileSystemObject")
DeleteFiles strFolder,strExtensionsToDelete, maxAge, includeSubFolders
wscript.echo "Finished"
sub DeleteFiles(byval strDirectory,byval strExtensionsToDelete,byval maxAge,includeSubFolders)
DIM objFolder, objSubFolder, objFile
DIM strExt
set objFolder = objFSO.GetFolder(strDirectory)
for each objFile in objFolder.Files
for each strExt in SPLIT(UCASE(strExtensionsToDelete),",")
if RIGHT(UCASE(objFile.Path),LEN(strExt)+1) = "." & strExt then
IF objFile.DateLastModified < (Now - MaxAge) THEN
wscript.echo "Deleting:" & objFile.Path & " | " & objFile.DateLastModified
objFile.Delete
exit for
END IF
end if
next
next
if includeSubFolders = true then ' Recursive delete
for each objSubFolder in objFolder.SubFolders
DeleteFiles objSubFolder.Path,strExtensionsToDelete,maxAge,includeSubFolders
next
end if
end sub
Now i want to create a log files to store the deleted files information (such as name of the file, when the script is run and user who run this script). Can any one help me with this ?
Thanks in Advance..
If I should go with your style pattern.
' outside your DeleteFiles()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set LogFile = objFSO.CreateTextFile(objFSO.GetTempName)
LogFile.WriteLine "DateTime: " & Now
LogFile.WriteLine "UserName: " & CreateObject("WScript.NetWork").UserName
DeleteFiles ...
' outside your DeleteFiles()
LogFile.Close
WScript.Echo "Finished"
Sub DeleteFiles(...
' inside For..Next in DeleteFiles()
LogFile.WriteLine objFile.Path
End Sub

VBScript: Getting error by batch renaming files within a folder

In this script I try to rename all the files within a folder. The new names I will gather from each textfiles in itself using Instr(1, strText, "(Amtlicher Gemeindeschlüssel = " ...). So all jsp-files shall be proceed. But I get an object-error almost at the end: 800A01A8 - Object Required. Can anyone helpme to replace the object strVerz.files so the the code works.
Thank U in advance.
Michael
Dim objFso, strFolder
' Begin Main
Set objFso = CreateObject("Scripting.FileSystemObject")
strFolder = objFso.GetParentFolderName(WScript.ScriptFullName)
If objFso.FolderExists(strFolder) Then
Call GetJspFiles(objFso.GetFolder(strFolder))
End If
Set objFso = Nothing
' End Main
Sub GetJspFiles(ByRef objFolder)
Dim objFile, objSubFolder
For Each objFile In objFolder.Files
If LCase(objFso.GetExtensionName(objFile.Name)) = "jsp" Then
Call JSPRename(objFile.Path, objFolder.Path)
End If
Next
For Each objSubFolder In objFolder.SubFolders
Call GetJspFiles(objSubFolder)
Next
' objFile.Close
End Sub
Sub JSPRename(ByRef strPath, ByRef strFolder)
Dim arrText, strText, strTextLine, Position , objJspFile, newFilename, strVerz
Set objJspFile = objFso.OpenTextFile(strPath)
arrText = Split(objJspFile.ReadAll, vbCrLf) ' split to lines
For Each strTextLine In arrText
If strTextLine <> "" Then
strText = Trim(strTextLine)
If Instr(1,strText,"(Amtlicher Gemeindeschlüssel",1) Then
Position=Instr(1, strText, "(Amtlicher Gemeindeschlüssel =",1)
newFilename=mid(strText,Position+31, 8)
else
end if
end if
Next
strVerz=objFSO.GetParentFoldername(WScript.ScriptFullName)
strNewName = strVerz & "\" & newFilename & ".jsp"
' Wscript.echo strNewName & vbcrlf & strVerz.files '!! only for Showing the results
objFSO.MoveFile strVerz.files, strNewName <- Here I get the error
objJspFile.Close
End Sub
It seems like the purpose of JSPRename is to rename the file given by strPath. In that case, the call to MoveFile should look like:
objFSO.MoveFile strPath, strNewName

VBS rename file to the same as a folder name

Is it possible to rename a file in a folder to its folder name using vbs? I have the following script which I am just using MsgBox at this time for debugging before I implement the renaming. for some reason tho ObjFolder doesnt change.
Option Explicit
Dim strFolderToSearch, objFSO, objRootFolder, objFolder, colSubfolders, strOutput, objStartFolder, colFiles, objFile
strFolderToSearch = "D:\Shared\Films"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objRootFolder = objFSO.GetFolder(strFolderToSearch)
Set colSubfolders = objRootFolder.SubFolders
For Each objFolder in colSubfolders
objStartFolder = objFolder
Set objFolder = objFSO.GetFolder(objStartFolder)
Set colFiles = objFolder.Files
For Each objFile in colSubfolders
MsgBox objFile.name & "," & objFolder.name
Next
Next
I admit that I can't follow the tangle of your folders, subfolders, and files. But if you want to rename files in a folder, use this stratege:
Dim sDName : sDName = "FancyRename"
Dim sDName2 : sDName2 = "," & sDName
Dim oFile, sNewName
For Each oFile In goFS.GetFolder(goFS.BuildPath("..\testdata", sDName)).Files
If 0 = Instr(oFile.Name, sDName2) Then
sNewName = Replace(oFile.Name, ".", sDName2 & ".")
Else
sNewName = Replace(oFile.Name, sDName2, "")
End If
WScript.Echo oFile.Name, "=>", sNewName
oFile.Name = sNewName
Next
output of running this three times:
that.txt => that,FancyRename.txt
this.txt => this,FancyRename.txt
that,FancyRename.txt => that.txt
this,FancyRename.txt => this.txt
that.txt => that,FancyRename.txt
this.txt => this,FancyRename.txt
UPDATE
How about: Given a folder D and a file name F (e.g. someavi.avi), rename all (existing) Fs in D and its sub folders to "subfoldername.avi", unless such a file already exists:
recursiveRename goFS.GetFolder("..\testdata\FancyRename"), "someavi", "avi"
Sub recursiveRename(oDir, sFiNa, sExt)
WScript.Echo "Looking into", oDir.Path
Dim sOFiNa : sOFiNa = sFiNa & "." & sExt
Dim sOFSpec : sOFSpec = goFS.BuildPath(oDir.Path, sOFiNa)
Dim sNFSpec
If goFS.FileExists(sOFSpec) Then
WScript.Echo "found ", sOFSpec
sNFSpec = goFS.BuildPath(oDir.Path, oDir.Name & "." & sExt)
If goFS.FileExists(sNFSpec) Then
WScript.Echo "found ", sNFSpec, "- can't rename"
Else
WScript.Echo "found no", sNFSpec, "- will rename"
goFS.MoveFile sOFSpec, sNFSpec
End If
Else
WScript.Echo "found no", sOFSpec
End If
Dim oSubF
For Each oSubF In oDir.SubFolders
recursiveRename oSubF, sFiNa, sExt
Next
End Sub
sample output:
Looking into M:\lib\kurs0705\testdata\FancyRename
found no M:\lib\kurs0705\testdata\FancyRename\someavi.avi
Looking into M:\lib\kurs0705\testdata\FancyRename\subfa
found no M:\lib\kurs0705\testdata\FancyRename\subfa\someavi.avi
Looking into M:\lib\kurs0705\testdata\FancyRename\subfc
found M:\lib\kurs0705\testdata\FancyRename\subfc\someavi.avi
found no M:\lib\kurs0705\testdata\FancyRename\subfc\subfc.avi - will rename
Looking into M:\lib\kurs0705\testdata\FancyRename\subfb
found M:\lib\kurs0705\testdata\FancyRename\subfb\someavi.avi
found M:\lib\kurs0705\testdata\FancyRename\subfb\subfb.avi - can't rename
UPDATE II
Changed specs: rename .avi to folder name, if there is exactly one .avi
recursiveRename03 goFS.GetFolder("..\testdata\FancyRename")
Sub recursiveRename03(oDir)
WScript.Echo "Looking into", oDir.Path
Dim sNFSpec : sNFSpec = goFS.BuildPath(oDir.Path, oDir.Name & ".avi")
If goFS.FileExists(sNFSpec) Then
WScript.Echo "found ", sNFSpec, "- can't rename"
Else
Dim oOFile : Set oOFile = Nothing
Dim oFile
For Each oFile In oDir.Files
If "avi" = goFS.GetExtensionName(oFile.Name) Then
If oOFile Is Nothing Then
Set oOFile = oFile
Else
WScript.Echo "Found second avi", oFile.Name
Set oOFile = Nothing
Exit For
End If
End If
Next
If oOFile Is Nothing Then
WScript.Echo "not exactly one avi found"
Else
WScript.Echo "found ", oOFile.Name, "- will rename"
oOFile.Name = oDir.Name & ".avi"
End If
End If
Dim oSubF
For Each oSubF In oDir.SubFolders
recursiveRename03 oSubF
Next
End Sub
UPDATE III
If you use a global FSO or pass an FSO to the Subs/Functions needing
it, you avoid its repetitive re-creation.
If you pass a folder/file object instead of a string to the
Subs/Functions dealing with such objects, you can access their
properties/methods immediately/for free (no need to reclaim/get back
info by string operations).
If you rename a file, you must check whether there is a file having
the new name (it's not sufficient to check whether the file you work
with doesn't have the new name).
Idealistically, your script should have the following features:
Recursion - For traversing folders that are 1-n deep from D:\Shared\Films
Rename file function - For renaming match files according to your rule.
I wrote the following script that features the following routines:
RenameAllVideos(strFolder) - this will recursively search subfolders
RenameVideo(strFileName) - will rename a match video file using your rule
Here's my script:
Option Explicit
Call RenameAllVideos("D:\Shared\Films")
Sub RenameAllVideos(strFolder)
Dim fso, file, folder
Set fso = CreateObject("Scripting.FileSystemObject")
' Check for AVIs to rename.
For Each file in fso.GetFolder(strFolder).Files
If Right(file.Name, 4) = ".avi" Then
Call RenameVideo(strFolder & "\" & file.Name)
End If
Next
' Check for SubFolders to recurse into.
For Each folder in fso.GetFolder(strFolder).SubFolders
Call RenameAllVideos(strFolder & "\" & folder.Name)
Next
End Sub
Sub RenameVideo(strFileName)
Dim fso, strExt, strFolder, strNewFileName
Set fso = CreateObject("Scripting.FileSystemobject")
' Note the extension (should be avi)
strExt = fso.GetExtensionName(strFileName)
' Derive the full path to the folder.
strFolder = fso.GetParentFolderName(strFileName)
' Derive the new filename.
strNewFileName = strFolder & "\" & fso.GetBaseName(strFolder) & "." & strExt
' Do the rename.
If strFileName <> strNewFileName Then
WScript.Echo "Renaming " & strFileName & " to " & strNewFileName
fso.MoveFile strFileName, strNewFileName
End If
End Sub

Resources