Excel Search in subfolders - vbscript

Using the following code that I pulled from the web, I'm able to do a search in a single directory for excel files containing a string in a certain row. How would I allow this to be recursive in all the subfolders as well? I've found a few answers but I just don't understand how I would implement them in my code. I only started messing with VBScript yesterday and I'm pretty confused about how to make this work.
strComputer = "CAA-W74109188"
Set objExcel = CreateObject("Excel.Application", strComputer)
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set FileList = objWMIService.ExecQuery _
("ASSOCIATORS OF {Win32_Directory.Name='c:\TDRS'} Where " _
& "ResultClass = CIM_DataFile")
For Each objFile In FileList
If (objFile.Extension = "xlsm" or objFile.Extension = "xls") Then
Set objWorkbook = objExcel.Workbooks.Open(objFile.Name)
Set objWorksheet = objWorkbook.Worksheets(1)
If objExcel.Cells(3,10) = "Complete" or objExcel.Cells(3,9) = "Released" Then
Wscript.Echo objFile.FileName
End If
objExcel.DisplayAlerts = False
objworkbook.Saved = False
objWorkbook.Close False
End If
Next
objExcel.Quit

Here is an script that I used to delete files with, which I have modified for your needs. A recursive function is what you need to get the job done and I have always found them to be interesting and kind of hard to wrap my head around.
Dim Shell : Set Shell = WScript.CreateObject( "WScript.Shell" )
Dim oFSO : Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim objExcel : Set objExcel = CreateObject("Excel.Application")
Dim Paths(0)
Paths(0) = "c:\temp"
For Each Path in Paths
FolderScan(Path)
Next
Sub FolderScan(Folder)
Set base = oFSO.GetFolder(Folder)
If base.SubFolders.Count Then
For Each folder in Base.SubFolders
FolderScan(folder.Path)
Next
End If
Set files = base.Files
If files.Count Then
For Each File in files
If LCase(oFSO.GetExtensionName(File.Path) = "xlsm") or _
LCase(oFSO.GetExtensionName(File.Path) = "xls") Then
Dim objWorkbook : Set objWorkbook = objExcel.Workbooks.Open(File.Path)
Dim objWorkSheet : Set objWorkSheet = objWorkbook.Worksheets(1)
If (objExcel.Cells(3,10) = "Complete" or _
objExcel.Cells(3,9) = "Released") Then
Wscript.echo File.Path
End if
objExcel.DisplayAlerts = False
objExcel.Quit
End If
Next
End If
End Sub

Here's a generic, recursive function that iterates all files and subfolders of a given folder object.
Dim FileSystem
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder("c:\somefolder")
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
' Operate on each file
Next
End Sub

Related

VBScript to get directory size if over N GB then delete oldest 'Folder' to recover space

I'm very new to bat scripting and would like to be able to do the following:
I have a main 'backups' folder which in turn contains unique folders for individual daily backups taken (i.e. named 'backup (date/time'). Within these individual daily backup folders they contain both files and folders.
I would therefore like to be able to check the main 'backups' folder and if the size is greater then say 50GB then the oldest folder and anything contained within is deleted.
I came across the script below in the Forum which does what I'm looking for, but on files rather then folders. Due to my elementally level of scripting, I'm not sure how straightforward it would be to adapt have it work with folders or if there is something else already available.
Many Thanks
Set fso = CreateObject("Scripting.FileSystemObject")
Set F = fso.GetFolder("C:\Users\User\Desktop\New Folder\Stories\Test")
If F.size > 2^30*2 Then
'Comments on a stupid editor that can't handle tabs
'Creating an in memory disconnected recordset to sort files by date
Set rs = CreateObject("ADODB.Recordset")
With rs
.Fields.Append "Date", 7
.Fields.Append "Txt", 201, 5000
.Open
For Each Thing in f.files
.AddNew
.Fields("Date").value = thing.datelastmodified
.Fields("Txt").value = thing.path
.UpDate
Next
.Sort = "Date Desc"
Do While not .EOF
fso.deletefile .Fields("Txt").Value
If f.size < 2^30*2 then Exit Do
.MoveNext
Loop
End With
End If
Here's code that does what you are looking for:
Dim objFSO
PurgeBackups "C:\Temp"
Sub PurgeBackups(p_sRootFolder)
Dim objRootFolder
Dim objOldestFolder
Dim fOldestInitialized
Dim objFolder
Dim lngFolderSize
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objRootFolder = objFSO.GetFolder(p_sRootFolder)
fOldestInitialized = False
For Each objFolder In objRootFolder.SubFolders
lngFolderSize = GetFolderSize(objFolder)
If lngFolderSize > 50000000000# Then
' Decide if you want to delete this Folder or not
If Not fOldestInitialized Then
Set objOldestFolder = objFolder
fOldestInitialized = True
End If
' Compare date
If objFolder.DateCreated < objOldestFolder.DateCreated Then
Set objOldestFolder = objFolder
End If
End If
Next
If fOldestInitialized Then
' Delete oldest folder
objOldestFolder.Delete
End If
End Sub
Function GetFolderSize(p_objFolder)
Dim objFile
Dim objFolder
Dim lngFolderSize
lngFolderSize = 0
For Each objFile In p_objFolder.Files
lngFolderSize = lngFolderSize + objFile.Size
Next
For Each objFolder In p_objFolder.SubFolders
lngFolderSize = lngFolderSize + GetFolderSize(objFolder)
Next
GetFolderSize = lngFolderSize
End Function
Please find below my attempt which has been based on an existing script and modified to suit, with a few extra flurries . . . I would be grateful for comment.
strOldestFolder = ""
dtmOldestDate = Now
Set oShell = CreateObject("WScript.Shell")
strHomeFolder = oShell.ExpandEnvironmentStrings("%USERPROFILE%\HDBackups")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strHomeFolder)
intFolderSize = Int((objFolder.Size / 1024) / 1024)
If intFolderSize >= 50 Then ' change as appropriate, value in MBytes
Set objSubFolders = objFolder.SubFolders
For Each objFolder in objSubFolders
strFolder = objFolder.Path
dtmFolderDate = objFolder.DateCreated
If dtmFolderDate < dtmOldestDate Then
dtmOldestDate = dtmFolderDate
strOldestFolder = strFolder
End If
Next
objFSO.DeleteFolder(strOldestFolder)
End If
One aspect that I'm not entirely happy with is the look and neatness of the 'str' and 'Set' in the first six code lines, I would like to be group them together, i.e. all the Sets together. But so far have been unable to do so without the script failing.
Note: have used 50MB rather then the 50GB as per original description, makes testing a bit easier.

Can not run vbs with current Folder directory

It is my first vbs experience.
I try to keep my Problem short.
This one works, when I run it with my .bat:
Option Explicit
On Error Resume Next
ExcelMacroExample
Sub ExcelMacroExample()
Dim xlApp
Dim xlBook
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("C:\.....\RunScript.xlsm", 0,
True)
xlApp.Run "Auto_Open"
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
And this one works (shows me my corect current directory with my file):
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
sScriptDir = oFSO.GetParentFolderName(WScript.ScriptFullName)
Wscript.Echo sScriptDir & "\RunScript.xlsm"
But if I combine them, it does not work:
Option Explicit
On Error Resume Next
ExcelMacroExample
Sub ExcelMacroExample()
Dim xlApp
Dim xlBook
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
sScriptDir = oFSO.GetParentFolderName(WScript.ScriptFullName)
Set fileDirectory = sScriptDir & "\RunScript.xlsm"
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(fileDirectory, 0,
True)
xlApp.Run "Auto_Open"
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
Like I said, thank you Dave. That works.
However I found another issue, now with vbA inside the RunScript.xlsm
This code works with the vbS before:
Sub Auto_Open()
Application.DisplayAlerts = False
ActiveWorkbook.RefreshAll
ActiveWorkbook.Save
ActiveWorkbook.SaveAs Filename:= _
"C:\...\MyCSV.csv" _
, FileFormat:=xlCSV, CreateBackup:=False
Application.DisplayAlerts = True
ThisWorkbook.Saved = True
Application.Quit
End Sub
But if I change here the path, it just works when I run the RunScript.xlsm, but not when I run my vbS:
Sub Auto_Open()
Application.DisplayAlerts = False
ActiveWorkbook.RefreshAll
ActiveWorkbook.Save
Dim relativePath As String
relativePath = Application.ActiveWorkbook.path & "\MyCSV.csv"
ActiveWorkbook.SaveAs Filename:=relativePath, FileFormat:=xlCSV, CreateBackup:=False
Application.DisplayAlerts = True
ThisWorkbook.Saved = True
Application.Quit
End Sub
I think it is beacause of the ActiveWorkbook, I tried already ThisWorkbook, and I tried it without Application.

Asking for a little assistance with cleanup and error

I have been given a task of creating a script that takes a log file (date is in the filename), pulls the data and posts it in event manager. I have a script that works as it should I know the script is ugly so please be gentle. I'm looking for 2 things.
some days nothing has happened and no log for the day was created. when this happens my script causes all kinds of slowness in the PC. I need help with a way for the script to not do its task if no new file has been added to the logs folder.
I would like a little help cleaning up the script.
Like i said i'm very new to this and i used scripts found on the web and fit them to do what i needed them to do.
any help would be greatly appricated.
Option Explicit
Const ForReading = 1
Dim strfolder
Dim FSO
Dim FLD
Dim fil
Dim strOldName
Dim strNewName
Dim strFileParts
Dim objShell
Dim objFSO
Dim objFolder
Dim strFileName
Dim objFile
Dim objTextFile
Dim strNextLine
Dim arrServiceList
Dim i
strFolder = "C:\Logs\"
Set objShell = CreateObject ("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(strFolder)
Set objShell = CreateObject ("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile ("C:\Logs\logCatchAll.log", ForReading)
For Each strFileName in objFolder.Items
If len(objFSO.GetExtensionName(strFileName)) > 0 Then
Set objFile = objFSO.GetFile(strFolder & strFileName.Name)
If DateDiff("H",objFile.DateLastModified,Now()) > 24 Then
objFSO.DeleteFile(strFolder & strFileName.Name),True
End If
End If
next
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FLD = FSO.GetFolder(strfolder)
For Each fil in FLD.Files
strOldName = fil.Path
If InStr(strOldName, "-") > 0 Then
strFileParts = Split(strOldName, "-")
strNewName = strFileParts(0) & ".log"
FSO.MoveFile strOldName, strNewName
End If
Next
Set FLD = Nothing
Set FSO = Nothing
Do Until objTextFile.AtEndOfStream
strNextLine = objTextFile.Readline
arrServiceList = Split(strNextLine , ",")
For i = 3 to Ubound(arrServiceList)
objshell.LogEvent 4, arrServiceList(i)
Loop
You can block your Dim'd variables
You are reactivating the objShell to many times
You have a for loop at the bottom of your code without a Next statement.
You don't need to iterate through the log file until it reaches AtEndOfStream, just store it in a variable first.
You can use the same objFSO more than once if your not resetting the object.
You need to include error handling so you know where your code breaks.
Revised code.
Option Explicit
'Handle errors manually.
On Error Resume Next
'Set Constants
Const ForReading = 1
'Set Strings
Dim strFolder, strOldName, strNewName, strFileName, strFileParts, strNextLine, TFStrings
strFolder = "C:\Logs\"
'Set Objects
Dim objShell, objFSO, objFolder, objFile, objTextFile
Set objShell = CreateObject ("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objShell.Namespace(strFolder)
TFStrings = split(objFSO.OpenTextFile("C:\Logs\logCatchAll.log", ForReading).ReadAll, vbcrlf)
'Set Other Variables
Dim FLD, fil, arrServiceList, i, executed
executed = false
'Delete file procedure...
For Each strFileName in objFolder.Items
If len(objFSO.GetExtensionName(strFileName)) > 0 Then
Set objFile = objFSO.GetFile(strFolder & strFileName.Name)
If DateDiff("H",objFile.DateLastModified,Now()) > 24 Then
objFSO.DeleteFile(strFolder & strFileName.Name),True
executed = true
End If
End If
Next
If executed then
If err.number <> 0 then
'File was found, but delete was unsuccessful, log failure of delete.
executed = false
err.clear
Else
'Delete file procedure executed successfully. Lets move on.
executed = false
End If
Else
'No file was found within the conditions. log failure of search.
End if
'Move file and rename procedure...
Set FLD = objFSO.GetFolder(strfolder)
For Each fil in FLD.Files
strOldName = fil.Path
If InStr(strOldName, "-") > 0 Then
strFileParts = Split(strOldName, "-")
strNewName = strFileParts(0) & ".log"
objFSO.MoveFile strOldName, strNewName
executed = true
End If
Next
Set FLD = Nothing
Set FSO = Nothing
If executed then
If err.number <> 0 then
'File was found, but move was unsuccessful, log failure of move.
executed = false
err.clear
Else
'Move file procedure executed successfully. Lets move on.
executed = false
End If
Else
'No file was found within the conditions. log failure of search.
End if
For Each line in TFStrings
strNextLine = line
arrServiceList = Split(strNextLine , ",")
For i = 3 to Ubound(arrServiceList)
objshell.LogEvent 4, arrServiceList(i)
Next
Next

VB.Net - List files & subfolders from a specified Directory and save to a text document, and sort results

I am working on a project that requires me to search and list all files in a folder that could have multiple sub folders and write it to text documents.
Primarily the file extension i will be searching for is a .Doc, but I will need to list the other files found in said directory as well.
To make things slightly more difficult I want the text documents to be sorted by File type and another by Directory.
I do not know how possible this is, but I have search for methods online, but have as of yet found correct syntax.
Any help will be greatly appreciated.
I write this in the past, should server as a base for your version. I know it's not .NET, still I hope it helps something. It prompts the user for a path to scan, recurses into folders, and writes the file name, path, and owner into a CSV file. Probably really inefficient and slow, but does the job.
Main() ' trickster yo
Dim rootFolder 'As String
Dim FSO 'As Object
Dim ObjOutFile
Dim objWMIService 'As Object
Sub Main()
StartTime = Timer()
If Wscript.Arguments.Count = 1 Then ' if path provided with the argument, use it.
rootFolder = Wscript.Arguments.Item(0)
Else
rootFolder = InputBox("Give me the search path : ") ' if not, ask for it
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ObjOutFile = FSO.CreateTextFile("OutputFiles.csv")
Set objWMIService = GetObject("winmgmts:")
ObjOutFile.WriteLine ("Path, Owner") ' set headers
Gather (rootFolder)
ObjOutFile.Close ' close the stream
EndTime = Timer()
MsgBox ("Done. (ran for " & FormatNumber(EndTime - StartTime, 2) & "s.)")
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Gather(FolderName)
On Error Resume Next
Dim ObjFolder
Dim ObjSubFolders
Dim ObjSubFolder
Dim ObjFiles
Dim ObjFile
Set ObjFolder = FSO.GetFolder(FolderName)
Set ObjFiles = ObjFolder.Files
For Each ObjFile In ObjFiles 'Write all files to output files
Set objFileSecuritySettings = _
objWMIService.Get("Win32_LogicalFileSecuritySetting='" & ObjFile.Path & "'")
intRetVal = objFileSecuritySettings.GetSecurityDescriptor(objSD)
If intRetVal = 0 Then
owner = objSD.owner.Domain & "\" & objSD.owner.Name
ObjOutFile.WriteLine (ObjFile.Path & ";" & owner) ' write in CSV format
End If
Next
Set ObjSubFolders = ObjFolder.SubFolders 'Getting all subfolders
For Each ObjFolder In ObjSubFolders
Set objFolderSecuritySettings = _
objWMIService.Get("Win32_LogicalFileSecuritySetting='" & ObjFile.Path & "'")
intRetVal = objFolderSecuritySettings.GetSecurityDescriptor(objSD)
If intRetVal = 0 Then
owner = objSD.owner.Domain & "\" & objSD.owner.Name
ObjOutFile.WriteLine (ObjFolder.Path & ";" & owner) ' write in CSV format
End If
Gather (ObjFolder.Path)
Next
End Function

Why doesn't this VBScript add files to a ZIP file?

I want to add a file to a folder and save it as a compressed folder in VBScript.
I've written the following code, but it only creates the ZIP file and doesn't add the files to it. What can be the problem with this code?
Option Explicit
dim wshShell
Const MoveMode = True
Const BackupDir = "D:\csv\Image\"
Const Outfilename = "MyZip.zip"
Const TimeoutMins = 10 ' Timeout for individual file compression operation
'Set wshShell = CreateObject("WScript.shell")
Dim FSO : set FSO = CreateObject("Scripting.FileSystemObject")
Dim Folder : Set Folder = FSO.GetFolder("D:\csv\Image")
Dim Files : Set Files = Folder.Files
Dim File
Dim Counter : Counter=0
Dim Timeout : Timeout = 0
FSO.CreateTextFile "D:\csv\" & OutFilename,true '.WriteLine "PK" & Chr(5) & Chr(6) & String(18, 0)
Dim Shell : Set Shell = CreateObject("Shell.Application")
Dim ZipFile: Set ZipFile = Shell.NameSpace("D:\csv\"& OutFilename)
If Not ZipFile Is Nothing Then
Shell.NameSpace("D:\csv\"&Outfilename).CopyHere "D:\csv\Image\calender.png"
End If
This shows waiting 500 ms after creating a new ZIP file before attempting to copy data into it. Have you tried using WScript.Sleep(500)?
Dim FSO : set FSO = CreateObject("Scripting.FileSystemObject")
Dim Shell : Set Shell = CreateObject("Shell.Application")
If Not FSO.FileExists("D:\csv\" & OutFilename) Then
NewZip("D:\csv\" & OutFilename)
End If
If Not ZipFile Is Nothing Then
Shell.NameSpace("D:\csv\" & Outfilename).CopyHere BackupDir & "calender.png"
End If
Sub NewZip(sNewZip)
'This script is provided under the Creative Commons license located
'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
'be used for commercial purposes with out the expressed written consent
'of NateRice.com
Set oNewZipFSO = CreateObject("Scripting.FileSystemObject")
Set oNewZipFile = oNewZipFSO.CreateTextFile(sNewZip)
oNewZipFile.Write Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
oNewZipFile.Close
Set oNewZipFSO = Nothing
Wscript.Sleep(500)
End Sub
(Untested)

Resources