VBScript issue with values in a table - vbscript

I have this code to build a table and send it via e-mail to business. They want to know, on a daily basis, how many files were transferred from a Source to a Destination, and if there's a difference in the number of files (possible failed/corrupted transfers). All this by folder.
The problem is that this code somehow misses the row of the Number of Missing Files in the Destination folder. It seems like if it were attributing the row in a random manner. The image below shows that even though the folder 3 is complete, it does say there is 1 missing file, and the folder 5 has 1 missing file (59 in the Source and only 58 in the Destination folder) and it states 0 missing items. What am I missing here?
The code is:
' >>> init a Windows Shell object to run system commands
SET WshShell = WScript.CREATEOBJECT("WScript.Shell")
' >>> load email Class code
WDIR = "D:\Kofax_Scripts"
SET objFSO = CreateObject("Scripting.FileSystemObject")
SET mailObjectFile = objFSO.OpenTextFile( WDIR & "\email.vbs", 1)
Execute mailObjectFile.ReadAll()
' >>> TEST passed arguments
If WScript.Arguments.Count = 0 Then
Wscript.echo vbCr & vbLf & "Usage is: cscript.exe //nologo Kofax_SAP_crosscheck.vbs DEV|PRD [date]" & vbCrLf
Wscript.echo "If date is not given, script uses system current date. To run this script for other dates, you must pass it in format YYYY-MM-DD"
wscript.quit
End If
If WScript.Arguments.Item(0) = "DEV" Then
Wscript.echo "Running in DEV..."
ElseIf WScript.Arguments.Item(0) = "PRD" Then
Wscript.echo "Running in PRD..."
Else
Wscript.echo vbCr & vbLf & "Environment parameter is wrong! Possible choices: DEV|PRD"
wscript.quit
End If
' >>> Get today's date
t1=Now()
Wscript.echo "starting at: " & t1
' >>> Set date to use for the files' date crosscheck
Dim date_cross_check
If WScript.Arguments.Count = 2 Then
date_cross_check = CDate(WScript.Arguments.Item(1))
Else
date_cross_check = t1
End If
' >>> compose date string from the files pathname to be checked
ano = Year(date_cross_check)
mes = Month(date_cross_check)
dia = Day(date_cross_check)
date_cross_check_str = ano & "/" & mes & "/" & dia
' Set lists of Folders to cross-check
Set KofaxFolders = CreateObject("Scripting.Dictionary")
Set SapFolders = CreateObject("Scripting.Dictionary")
KofaxFolders.Add "AMOS", CreateObject("Scripting.Dictionary")
KofaxFolders.Add "bomdia", CreateObject("Scripting.Dictionary")
KofaxFolders.Add "cockpit", CreateObject("Scripting.Dictionary")
KofaxFolders.Add "irreg", CreateObject("Scripting.Dictionary")
KofaxFolders.Add "miro", CreateObject("Scripting.Dictionary")
KofaxFolders.Add "BSP", CreateObject("Scripting.Dictionary")
SapFolders.Add "AMOS", CreateObject("Scripting.Dictionary")
SapFolders.Add "bomdia", CreateObject("Scripting.Dictionary")
SapFolders.Add "cockpit", CreateObject("Scripting.Dictionary")
SapFolders.Add "irreg", CreateObject("Scripting.Dictionary")
SapFolders.Add "miro", CreateObject("Scripting.Dictionary")
SapFolders.Add "BSP", CreateObject("Scripting.Dictionary")
' init dictionaries
For each key in KofaxFolders
KofaxFolders(key).Add "files", CreateObject("Scripting.Dictionary")
KofaxFolders(key).Add "count", 0
Next
For each key in SapFolders
SapFolders(key).Add "files", CreateObject("Scripting.Dictionary")
SapFolders(key).Add "missing", 0
SapFolders(key).Add "count", 0
Next
' init File System Object
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Loop on KofaxFolders to fill contents folders
for each key in KofaxFolders
fldr = "D:\Projetos\EXPORT\" & key &"\Save\"& ano &"\"& mes &"\"& dia
If (objFSO.FolderExists(fldr)) Then
Set objFolder = objFSO.GetFolder(fldr)
For Each objFile In objFolder.Files
' Don't consider garbage files like Thumbs.db
If ( objFile.name <> "Thumbs.db" ) Then
' Wscript.echo "Folder : " & key & "Filename: " & objFile.name & ", size (bytes): " & objFile.size
KofaxFolders(key)("files").Add objFile.name, objFile.size
KofaxFolders(key)("count") = KofaxFolders(key)("count") + 1
End If
Next
End If
next
' Loop on SapFolders to fill contents folders
for each key in SapFolders
Set objFolder = objFSO.GetFolder("\\iftpv01\TPP\transdata\InB\OCRSave\Save"&key)
'WScript.Echo "Folder : " & key
For Each objFile In objFolder.Files
'Wscript.echo "Folder : " & key & "Filename: " & objFile.name & ", size (bytes): " & objFile.size
' Check only SAP files with last Modified Date equal to specified date
' --------------------------------------------------------------------
If ( DateDiff("d",objFile.DateLastModified, CDate(date_cross_check)) = 0 )Then
' Don't consider garbage files like Thumbs.db
If ( objFile.name <> "Thumbs.db" ) Then
SapFolders(key)("files").Add objFile.name, objFile.size
SapFolders(key)("count") = SapFolders(key)("count") + 1
End If
End If
Next
next
' ------------------------'
' Start new empty log file'
' ------------------------'
Dim log_file
log_file = WDIR & "\tmp\kofax_sap_crosscheck.log"
Set objLogFile = objFSO.CreateTextFile(log_file,True)
objLogFile.Close
' open file in write mode
Set objLogFile = objFSO.OpenTextFile(log_file, 2)
' Loop on KofaxFolders Contents and check if file exists in SAP structure
For each key in KofaxFolders
For each file in KofaxFolders(key)("files")
If ( NOT SapFolders(key)("files").Exists(file) ) Then
objLogFile.WriteLine("file " & file & " is missing from InB SAP folder "&key)
SapFolders(key)("missing") = SapFolders(key)("missing") + 1
Else
' If file size is different between Kofax and SAP, this may be due to corrupt transfer
If SapFolders(key)("files")(file) <> KofaxFolders(key)("files")(file) Then
objLogFile.WriteLine("file " & file & " has not same size in SAP and Kofax " & key &" Folders!!! Kofax size: " _
& KofaxFolders(key)("files")(file) & "| SAP size: " _
& SapFolders(key)("files")(file) _
)
SapFolders(key)("missing") = SapFolders(key)("missing") + 1
End If
End If
Next
Next
' close log file
objLogFile.Close
' compute execution time
exec_time = datediff("s",t1,Now)
' Global missing count
Dim missing_files : missing_files = 0
For each key in SapFolders
missing_files = missing_files + SapFolders(key)("missing")
Next
' Build summary HTML table according to "missing_files" count
Dim rep_table : rep_table = ""
if ( missing_files > 0 )Then
rep_table = "<table border=""1""><tr><th>Folder</th><th>Nr of files Source</th><th>Nr of files Dest</th><th>Nr of Files missing Dest</th></tr>"
For each key in SapFolders
rep_table = rep_table & "<tr><td>" & key & "</td><td align=""right"">" & KofaxFolders(key)("count") &"</td><td align=""right"">" & SapFolders(key)("count") & "</td>"
if ( SapFolders(key)("missing") > 0 ) Then
rep_table = rep_table & "<td align=""right"" bgcolor=""#FF0000"">"
Else
rep_table = rep_table & "<td align=""right"">"
End If
rep_table = rep_table & SapFolders(key)("missing") &"</td></tr>"
Next
Else
rep_table = "<table border=""1""><tr><th>Pasta</th><th>Nº ficheiros no Kofax</th><th>Nº ficheiros no SAP</th></tr>"
For each key in SapFolders
rep_table = rep_table & "<tr><td>" & key & "</td><td align=""right"">" & KofaxFolders(key)("count") &"</td><td align=""right"">" & SapFolders(key)("count") & "</td></tr>"
Next
End If
rep_table = rep_table & "</table>"

I am not 100% sure about what is happening here, but I think that the issue is that SapFolders is a dictionary and you are using the line
For each key in SapFolders
to iterate over it when creating the table. The order of keys in such an iteration is (essentially) random. In your case, it isn't true that the loop iterate over the keys "AMOS", "bomdia", "cockpit", "irreg", "miro", "BSP" in that order.
What you could do is to create an array:
keys = Array("AMOS", "bomdia", "cockpit", "irreg", "miro", "BSP")
and replace every loop which begins
For each key in SapFolders
by
For i = 0 to UBound(keys)
key = keys(i)
(and maybe do a similar move for iterations involving KofaxFolders).
This will guarantee that you know the order with which you are populating the report table.

Related

Identify and Copy latest files in directory

Everyday around 7 AM there are 3 csv exports extracted into a specific folder and the file names are exactly the same each day except everyday the prefix of the file name is amended to the current date.
Example:
16-02-2018_Test1 will change to 17-02-2018_Test1
16-02-2018_Test2 will change to 17-02-2018_Test2
16-02-2018_Test3 will change to 17-02-2018_Test3
The file itself is not replaced, the new file with the current date is instead added to this folder.
What I need to do is identify the 3 extracts each day and copy them to a sub-folder. The best way I thought of doing this is by identifying the date at which the file was last modified.
I have the below VBS code I found and helps identifies the latest file in a directory and I added a line that will copy that file to a new directory.
The issue however, is that the code only identifies 1 file instead of 3 and I can only copy 1 file instead of 3. If anyone has better code to help me achieve the desired result or alternatively can help modify the existing code to achieve the desired result.
sPath = "C:\Users\Desktop\Test\"
Const sToDir = "C:\Users\Desktop\Test\NewFolder\"
Set oFSO = CreateObject("Scripting.FileSystemObject")
sNewestFile = GetNewestFile(sPath)
If sNewestFile <> "" Then
WScript.Echo "Newest file is " & sNewestFile
dFileModDate = oFSO.GetFile(sNewestFile).DateLastModified
If DateDiff("n", dFileModDate, Now) > 60 Then
oFSO.CopyFile sNewestFile, sToDir
End If
Else
WScript.Echo "Directory is empty"
End If
Function GetNewestFile(ByVal sPath)
sNewestFile = Null ' init value
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
Set oFiles = oFolder.Files
' enumerate the files in the folder, finding the newest file
For Each oFile In oFiles
On Error Resume Next
If IsNull(sNewestFile) Then
sNewestFile = oFile.Path
dPrevDate = oFile.DateLastModified
Elseif dPrevDate < oFile.DateLastModified Then
sNewestFile = oFile.Path
dPrevDate = oFile.DateLastModified
End If
On Error Goto 0
Next
If IsNull(sNewestFile) Then sNewestFile = ""
GetNewestFile = sNewestFile
End Function
Invest some work in a useful format class and
just look for the 3 files of the day (FileExists)
if they are not there, look for the previous day's files
or
search for the newest file and build all three file names from the prefix
In code:
Option Explicit
' stolen from https://stackoverflow.com/a/21643663/603855
' added formatTwo; left as exercise: formatThree
Class cFormat
Private m_oSB
Private Sub Class_Initialize()
Set m_oSB = CreateObject("System.Text.StringBuilder")
End Sub ' Class_Initialize
Public Function formatOne(sFmt, vElm)
m_oSB.AppendFormat sFmt, vElm
formatOne = m_oSB.ToString()
m_oSB.Length = 0
End Function ' formatOne
Public Function formatTwo(sFmt, vElm1, vElm2)
m_oSB.AppendFormat_2 sFmt, vElm1, vElm2
formatTwo = m_oSB.ToString()
m_oSB.Length = 0
End Function ' formatOne
Public Function formatArray(sFmt, aElms)
m_oSB.AppendFormat_4 sFmt, (aElms)
formatArray = m_oSB.ToString()
m_oSB.Length = 0
End Function ' formatArray
End Class ' cFormat
Dim oFmt : Set oFmt = New cFormat
Dim sFmt : sFmt = "{0:dd-MM-yyyy}_Test{1}"
Dim dToday : dToday = Date()
Dim i
WScript.Echo "file names expected today " & oFmt.formatOne("({0:yyyy-MMM-d}).", dToday)
For i = 1 To 3
WScript.Echo oFmt.FormatTwo(sFmt, dToday, i)
Next
WScript.Echo oFmt.formatArray("look for {0} if {1} is missing on the {2:dd}th after 7 AM" _
, Array(oFmt.FormatTwo(sFmt, DateAdd("d", -1, dToday), 1), oFmt.FormatTwo(sFmt, dToday, 1), dToday))
Dim sFnd : sFnd = oFmt.FormatTwo(sFmt, dToday, 2)
WScript.Echo "if your GetNewestFile() finds " & sFnd & ", copy:"
For i = 1 To 3
WScript.Echo Left(sFnd, Len(sFnd) - 1) & i
Next
output:
cscript 48866113.vbs
file names expected today (2018-Feb-19).
19-02-2018_Test1
19-02-2018_Test2
19-02-2018_Test3
look for 18-02-2018_Test1 if 19-02-2018_Test1 is missing on the 19th after 7 AM
if your GetNewestFile() finds 19-02-2018_Test4, copy:
19-02-2018_Test1
19-02-2018_Test2
19-02-2018_Test3
Thanks to everyone for the help, I found the answer on a different thread. Here is the link: Copy 2 latest text file from a source folder to destination folder
Below is the code:
Option Explicit
Dim FolderToCheck, FolderDestination, FileExt, mostRecent, noFiles, fso, fileList, file, filecounter, oShell, strHomeFolder
' Enumerate current user's home path - we will use that by default later if nothing specified in commandline
Set oShell = CreateObject("WScript.Shell")
strHomeFolder = oShell.ExpandEnvironmentStrings("%USERPROFILE%")
'Variables -----
folderToCheck = strHomeFolder & "\Desktop\MY\MMS" ' Folder Source to check for recent files to copy FROM
folderDestination = strHomeFolder & "\Desktop\New" ' Destination Folder where to copy files TO
fileExt = "txt" ' Extension we are searching for
mostRecent = 2 ' Most Recent number of files to copy
' --------------
PreProcessing() ' Retrieve Command Line Parameters
' Display what we are intending on doing
wscript.echo "Checking Source: " & FolderToCheck
wscript.echo "For Files of type: " & FileExt
wscript.echo "Copying most recent "& mostRecent &" file(s) to: " & FolderDestination & "."
wscript.echo
noFiles = TRUE
Set fso = CreateObject("Scripting.FileSystemObject")
Set fileList = CreateObject("ADOR.Recordset")
fileList.Fields.append "name", 200, 255
fileList.Fields.Append "date", 7
fileList.Open
If fso.FolderExists(FolderToCheck) Then
For Each file In fso.GetFolder(FolderToCheck).files
If LCase(fso.GetExtensionName(file)) = LCase(FileExt) then
fileList.AddNew
fileList("name").Value = File.Path
fileList("date").Value = File.DateLastModified
fileList.Update
If noFiles Then noFiles = FALSE
End If
Next
If Not(noFiles) Then
wscript.echo fileList.recordCount & " File(s) found. Sorting and copying last " & mostRecent &"..."
fileList.Sort = "date DESC"
If Not(fileList.EOF) Then
fileList.MoveFirst
If fileList.recordCount < mostRecent Then
wscript.echo "WARNING: " & mostRecent &" file(s) specified but only " & fileList.recordcount & " file(s) match criteria. Adjusted to " & fileList.RecordCount & "."
mostRecent = fileList.recordcount
End If
fileCounter = 0
Do Until fileList.EOF Or fileCounter => mostRecent
If Not(fso.FolderExists(folderDestination)) Then
wscript.echo "Destination Folder did not exist. Creating..."
fso.createFolder folderDestination
End If
fso.copyfile fileList("name"), folderDestination & "\", True
wscript.echo fileList("date").value & vbTab & fileList("name")
fileList.moveNext
fileCounter = fileCounter + 1
Loop
Else
wscript.echo "An unexpected error has occured."
End If
Else
wscript.echo "No matching """ & FileExt &""" files were found in """ & foldertocheck & """ to copy."
End If
Else
wscript.echo "Error: Source folder does not exist """ & foldertocheck & """."
End If
fileList.Close
Function PreProcessing
Dim source, destination, ext, recent
' Initialize some variables
Set source = Nothing
Set destination = Nothing
Set ext = Nothing
Set recent = Nothing
'Get Command Line arguments
' <scriptname>.vbs /Source:"C:\somepath\somefolder" /Destination:"C:\someotherpath\somefolder" /ext:txt /recent:2
source = wscript.arguments.Named.Item("source")
destination = wscript.arguments.Named.Item("destination")
ext = wscript.arguments.Named.Item("ext")
recent = wscript.arguments.Named.Item("recent")
If source <> "" Then FolderToCheck = source
If destination <> "" Then FolderDestination = destination
If ext <> "" Then FileExt = ext
If recent <> "" Then mostRecent = int(recent)
End Function

Create Folders and Subfolders using VBS

I want to be able to create a set amount of folders and subfolders within a directory. I already have a code that loops through and creates the folders and subfolders. Is there anyway to create a set amount of these folders? Also I want to be able to create them sequentially. For example I already have 2000 folders in there. I would want to create a thousand more but it would start from 2001 to 3000. I basically want to automate the code i have below so no one has to go in and keep changing the values in the script. Thank you!
Here is the code:
Dim oFSO,Folder
Set oFSO = CreateObject("Scripting.FileSystemObject")
For i = 1001 To 2000
' x=msgbox("Directorie " & i ,64, "MakeDir")
If Not oFSO.FolderExists(i) Then
oFSO.CreateFolder i
End If
If Not oFSO.FolderExists(i & "/Text") Then
oFSO.CreateFolder i & "/Text"
End If
If Not oFSO.FolderExists(i & "/Text") Then
oFSO.CreateFolder i & "/Text"
End If
If Not oFSO.FolderExists(i & "/Text") Then
oFSO.CreateFolder i & "/Text"
End If
If Not oFSO.FolderExists(i & "/TestData") Then
oFSO.CreateFolder i & "/TestData"
End If
Next
Give this a try...
BaseFolder = "C:\temp" 'Root folder to look for/create subfolders in
MaxSize = 5 'the number of characters to allow in folder name
PaddingCharacter = "0" 'padding folder names with zeros for proper sorting
NumFolders = 10 'number of additional folder to create
intStart = GetLastFolder(BaseFolder)
If IsNull(intStart) Then
intStart = 1
Else
'skip
End If
For i = intStart To intStart + NumFolders
strFolderName = BaseFolder & "\" & RightPad( i, MaxSize, PaddingCharacter )
Wscript.Echo strFolderName
CreateFolders(strFolderName)
Next
Function GetLastFolder(strFolder)
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFolder = fso.GetFolder(BaseFolder)
Set subFlds = objFolder.SubFolders
For Each fld in subFlds
s = fld.Name
Next
x=Len(s)
For i=0 to x-1
If Mid(s,i+1,1) = "0" Then
'skip
Else
s = Mid(s,i+1,x)
Exit For
End If
Next
GetLastFolder = s
End Function
Function CreateFolders(i)
Dim oFSO,Folder
Set oFSO = CreateObject("Scripting.FileSystemObject")
If Not oFSO.FolderExists(i) Then
oFSO.CreateFolder i
End If
If Not oFSO.FolderExists(i & "/Text") Then
oFSO.CreateFolder i & "/Text"
End If
If Not oFSO.FolderExists(i & "/Text") Then
oFSO.CreateFolder i & "/Text"
End If
If Not oFSO.FolderExists(i & "/Text") Then
oFSO.CreateFolder i & "/Text"
End If
If Not oFSO.FolderExists(i & "/TestData") Then
oFSO.CreateFolder i & "/TestData"
End If
End Function
Function RightPad( strText, intLen, chrPad )
'Example: RightPad( "1000", 7, "0" ) = "0001234"
'Example: RightPad( "1000", 4, "0" ) = "1000"
RightPad = Right( String( intLen, chrPad ) & strText, intLen )
End Function

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.)

Zipping files from different folders preserving the directory structure

I've hacked together some pretty interesting code to zip multiple files and folders.
The script will take a list of arguments (files & folders) and zips them to a zip with the date/time as the name.
So I need some code that is executed when the argument is a file. The code should add the directory structure of the file to the zip file.
'=================== THE SCRIPT =====================================
'Get command-line arguments.
Set objArgs = WScript.Arguments
Set objShell = CreateObject("Shell.Application")
'
'C:\DateYYYY-MM-DD_TimeHH-MM-SS.zip
ZipFile = "C:\DateYYYY-MM-DD_TimeHH-MM-SS.zip"
'Create empty ZIP file.
CreateObject("Scripting.FileSystemObject").CreateTextFile(ZipFile, True).Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
Set zip = objShell.NameSpace(ZipFile)
'
for i = 0 To objArgs.Count-1
On Error Resume Next
IF fnFileExists( objArgs(i) ) OR (NOT fnFolderIsEmpty( objArgs(i) )) THEN
'WScript.Echo "Copying - " & objArgs(i)
IF fnFileExists( objArgs(i) ) THEN
'??? Code/Function/CopyHere[option] to create a directory structure in zip and copy objArgs(i) file into it
End If
zip.CopyHere( objArgs(i) )
Else
WScript.Echo "Empty or !Exist - " & objArgs(i)
End If
Do
wScript.Sleep 200
Loop Until objShell.NameSpace(zip).Items.Count >= i
Next
WScript.Echo "THE END"
The fnFileExists() function returns TRUE only if the file exists (FALSE if folder or file doesn't exist).
The fnFolderIsEmpty() function returns TRUE if folder is empty or doesn't exist.
Given a call like this:
"wscript zip.vbs "c:\Folder1\" "c:\Folder2\Sub2-1\" "c:\Windows\System32\TestFile0.txt"
Where folders are like this:
\Folder1\
└──TestFile1.txt
└──TestFile2.txt
\Folder2\
└──\Sub2-1\
└──TestFile3.txt
└──TestFile4.txt
\Windows\
└──\System32\
└──TestFile0.txt
└──\Sub3-2\
└──TestFoo.txt
I get a zip file with a structure like this:
\Folder1\
└──TestFile1.txt
└──TestFile2.txt
\Sub2-1\
└──TestFile3.txt
└──TestFile4.txt
\TestFile0.txt
This is what I'd LIKE it to look like:
\Folder1\
└──TestFile1.txt
└──TestFile2.txt
\Folder2\
└──\Sub2-1\
└──TestFile3.txt
└──TestFile4.txt
\Windows\
└──\System32\
└──TestFile0.txt
I did find the following, but I don't know how/if Java translates to VBScript:
java.util.zip - Recreating directory structure
-AND-
Zipping files preserving the directory structure
OK, here it is.
For every individual file, I put it in a temp folder ("C:\xxMisc") creating the full path underneath the temp folder. I then zip all the folders in the temp folder. Works perfect for my purposes.
e.g. If I needed to zip "c:\windows\system32\bob.dll"
I would create a path\file "c:\xxMisc\windows\system32\" & copy bob.dll into it.
Then call: zip.MoveHere( "c:\xxMisc\Windows" );
The result is that the zip file would have a "\windows\" directory with all the sub-directories (and files) in it.
Usage: wscript <script.vbs> [/x] <FullPath[FileName]>
[]arguments are optional. Wild cards do not work. End full paths with '\'. "/x" will bring up a IE debug window.
wscript script.vbs /X "C:\My Path\" "c:\windows\system32\bob.dll"
Result: zip file at "c:\" that will contain the entire directory "c:\My Path\" (including files & subdirectories) and bob.dll in a "\windows\system32\" directory path.
Here is the code.
IF WScript.Arguments.Count = 0 THEN
WSCript.Quit
END IF
Dim objIEDebugWindow
sTempFolderName = "C:\xxMisc" 'Where individual files go
iBeforeCopy = 0 'Value to detect when a move/copy is complete
bDebug = FALSE 'Debug Flag
i = 0 'Index through the objArgs()
'Get command-line arguments.
Set objArgs = wScript.Arguments
'General objects
Set objShell = CreateObject("Shell.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Detect Debug Command Line Argument | MUST be FIRST Argument
IF UCase( objArgs( 0 ) ) = "/X" THEN
bDebug = TRUE
i = 1 'Change Which Index objArgs() to start looking for files/folders
END IF
'Test to see if Windows Script Host is >= 2.0
fnCheckWSHversion( 2000 )
'Create empty ZIP file.
'C:\DateYYYY-MM-DD_TimeHH-MM-SS.zip
ZipFile = "C:\Date" & Year(Date) & "-" & Right("0" & Month(Date),2) & "-" & Right("0" & Day(Date),2) & "_Time" & Right("0" & Hour(now), 2) & "-" & Right("0" & Minute(now), 2) & "-" & Right("0" & Second(now), 2) & ".zip"
CreateObject("Scripting.FileSystemObject").CreateTextFile(ZipFile, True).Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
Set zip = objShell.NameSpace(ZipFile)
CALL Debug ( objArgs.Count )
'Iterate through the command line arguments
for i = i To objArgs.Count-1
CALL Debug( "Processing objArgs = " & i & "| " & objArgs(i) )
IF FileExists( objArgs(i) ) OR (NOT fnFolderIsEmpty( objArgs(i) )) THEN
IF FileExists( objArgs(i) ) THEN
'IT'S A FILE
CALL Debug( "Copying File - " & objArgs(i) )
CALL fnMakeTempFile( sTempFolderName, objArgs( i ) )
Else 'IT'S A FOLDER
CALL Debug( "Copying Folder - " & objArgs(i) )
iBeforeCopy = objShell.NameSpace(zip).Items.Count
zip.CopyHere( objArgs(i) )
'Wait until copy is done (Items.Count goes up)
Do
wScript.Sleep 200
Loop Until objShell.NameSpace(zip).Items.Count > iBeforeCopy
End If
Else
CALL Debug( "Empty or !Exist - " & objArgs(i) )
End If
Next
IF (NOT fnFolderIsEmpty( "c:\xxMisc" )) THEN 'Just in case no FILES were backed up
'Get ArrayList of Temp Folders
Set arrDirs = fnListDirIn( "c:\xxMisc" )
CALL Debug( "Copying sTempFolder" )
For Each sFolderName in arrDirs
CALL Debug( "sFolderName=" & sFolderName )
iBeforeCopy = objShell.NameSpace(zip).Items.Count
zip.MoveHere( sFolderName )
'Wait until copy is done (Items.Count goes up)
Do
wScript.Sleep 200
Loop Until objShell.NameSpace(zip).Items.Count > iBeforeCopy
Next
CALL Debug( "COPY DONE!" )
CALL Debug( "Deleting sTempFolderName = " & sTempFolderName )
objFSO.DeleteFolder sTempFolderName, TRUE
'Wait until folder is finished deleting; because MoveHere doesn't MOVE
While objFSO.FolderExists( sTempFolderName )
wScript.Sleep 200
Wend
END IF
CALL Debug( "THE END" )
CALL MsgBox( "Backup Complete", vbOKOnly+vbInformation, "My Backup" )
Set objArgs = Nothing
Set objShell = Nothing
Set objFSO = Nothing
Set zip = Nothing
wScript.Quit
' ----------------------------------------------
'END MAIN
' ----------------------------------------------
' ----------------------------------------------
'Copies sFileName into a temporary directory specified by sTempFolder
' e.g.:
' sTempFolder = "C:\Temp\"
' sFileName = "c:\Windows\System32\bob.ocx"
' results is the creation of "C:\Temp\Windows\System32\bob.ocx"
'-Uses fnCreatePath()
'-No Return
Function fnMakeTempFile( ByVal sTempFolder, sFileName )
IF Right( sTempFolder, 1 ) <> "\" THEN
sTempFolder = sTempFolder & "\"
End If
Set objFile = objFSO.GetFile( sFileName )
FilePath = objFSO.GetParentFolderName( objFile )
FilePath = sTempFolder & Mid(FilePath, 4)
fnCreatePath( FilePath )
CALL Debug( "FILECOPY = "& objFile.Name &" -> FilePath = " & FilePath )
objFile.Copy( FilePath & "\" & objFile.Name )
While NOT objFSO.FileExists( FilePath & "\" & objFile.Name )
wScript.Sleep 200
CALL Debug( "FileCopy Waiting" )
Wend
CALL Debug( "Temp FileCopy Completed" )
Set objFile = Nothing
End Function
' ----------------------------------------------
'Recursively creates a folder path
'Based on script from:
'http://www.techcoil.com/blog/handy-vbscript-functions-for-dealing-with-zip-files-and-folders/
Function fnCreatePath( folderUrl )
folderUrl = objFSO.GetAbsolutePathName(folderUrl)
If (Not objFSO.folderExists(objFSO.GetParentFolderName(folderUrl))) then
' Call CreateFolder recursively to create the parent folder
fnCreatePath(objFSO.GetParentFolderName(folderUrl))
End If
' Create the current folder if the parent exists
If (Not objFSO.FolderExists(folderUrl)) then
CALL Debug( "fnCreatePath; FolderURL = " & folderUrl )
objFSO.CreateFolder(folderUrl)
End If
End Function
' ----------------------------------------------
' Will return TRUE if folder is Empty or !Exist
Function fnFolderIsEmpty( sFolderName )
Dim objFolderFSO 'FileSystemObject
Dim objFolder
Set objFolderFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fnFolderIsEmpty = TRUE 'Return TRUE if it doesn't exist either
If objFolderFSO.FolderExists( sFolderName ) Then
Set objFolder = objFolderFSO.GetFolder( sFolderName )
If objFolder.Files.Count = 0 And objFolder.SubFolders.Count = 0 Then
fnFolderIsEmpty = TRUE
Else
fnFolderIsEmpty = FALSE
End If
End If
objFolderFSO = Nothing
objFolder = Nothing
End Function
' ----------------------------------------------
'Purpose: Return True if the file exists, even if it is hidden.
'Arguments: strFile: File name to look for. Current directory searched if no path included.
'Note: Does not look inside subdirectories for the file.
'Author: Allen Browne. http://allenbrowne.com June, 2006.
Function FileExists( strFile )
On Error Resume Next
DIM fso
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FileExists( strFile )) Then
FileExists = TRUE
Else
FileExists = FALSE
End If
fso = Nothing
End Function
'---------------------------------------------------------------
'Based on: http://blogs.msdn.com/b/gstemp/archive/2004/08/11/213028.aspx
' Returns ArrayList of folders found in sDirectory
Function fnListDirIn( ByVal sDirectory )
Set objWMIService = GetObject("winmgmts:\\.")
CALL Debug( "fnListDirIn() Path=" & sDirectory )
Set colFolders = objWMIService.ExecQuery _
("ASSOCIATORS OF {Win32_Directory.Name='" & sDirectory & "'} " _
& "WHERE AssocClass = Win32_Subdirectory " _
& "ResultRole = PartComponent")
Set arrNames = CreateObject("System.Collections.ArrayList")
For Each objFolder in colFolders
CALL Debug( "fnListDirIn Add Folder=" & objFolder.Name )
arrNames.Add( objFolder.name )
Next
'colFolders = Nothing ?Why does this fail?
'objFolder = Nothing ?Why does this fail?
Set fnListDirIn = arrNames
End Function
' ----------------------------------------------
'Checks available Windows Scripting Host Version
' - Quit Script if not available
'Based on: http://www.robvanderwoude.com/vbstech_debugging.php
Function fnCheckWSHversion( ByVal iMinVer )
intMajorVerion = 0 + CInt( Mid( WScript.Version, 1, InStr( WScript.Version, "." ) - 1 ) )
intMinorVerion = 0 + CInt( Mid( WScript.Version, InStr( WScript.Version, "." ) + 1 ) )
intCheckVersion = 1000 * intMajorVerion + intMinorVerion
CALL Debug( "WSH Version = " & intCheckVersion )
If intCheckVersion < iMinVer Then
WScript.Echo "Sorry, this script requires WSH " & iMinVer/1000 & " or later"
WScript.Quit intCheckVersion
End If
End Function
' ----------------------------------------------
' Dumps debug myText to an InternetExplorer Window
' Based on script from:
' http://www.robvanderwoude.com/vbstech_debugging.php
Sub Debug( myText )
' Uncomment the next line to turn off debugging
IF NOT bDebug THEN
Exit Sub
END IF
If Not IsObject( objIEDebugWindow ) Then
Set objIEDebugWindow = CreateObject( "InternetExplorer.Application" )
objIEDebugWindow.Navigate "about:blank"
objIEDebugWindow.Visible = True
objIEDebugWindow.ToolBar = False
objIEDebugWindow.Width = 200
objIEDebugWindow.Height = 300
objIEDebugWindow.Left = 10
objIEDebugWindow.Top = 10
Do While objIEDebugWindow.Busy
WScript.Sleep 100
Loop
objIEDebugWindow.Document.Title = "IE Debug Window"
objIEDebugWindow.Document.Body.InnerHTML = _
"<b>" & Now & "</b></br>"
End If
objIEDebugWindow.Document.Body.InnerHTML = _
objIEDebugWindow.Document.Body.InnerHTML _
& myText & "<br>" & vbCrLf
'Do NOT set objIEDebugWindow = Nothing; Will go away
End Sub
Let me know what you think. Thanks.

Trying to use Shell object and FileSystemObject in VBScript for file manipulation

I am trying to recursively loop through hundreds of directories, and thousands of JPG files to gather sort the files in new folders by date. So far, I am able to individually GetDetailsOf the files using the Shell NameSpace object, and I am also able to recursively loop through directories using the FileSystemObject. However, when I try to put them together in functions, etc, I am getting nothing back when I try to get the DateTaken attribute from the photo.
Here is my code so far:
sFolderPathspec = "C:\LocationOfFiles"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(sFolderPathspec)
Dim arrFiles()
getInfo(objDir)
Sub getInfo(pCurrentDir)
fileCount = 0
For Each strFileName In pCurrentDir.Files
fileCount = fileCount + 1
Next
ReDim arrFiles(fileCount,2)
i=0
For Each aItem In pCurrentDir.Files
wscript.Echo aItem.Name
arrFiles(i,0) = aItem.Name
strFileName = aItem.Name
strDir = pCurrentDir.Path
wscript.echo strDir
dateVar = GetDatePictureTaken(strFileName, strDir)
'dateVar = Temp2 & "_" & Temp3 & "_" & Temp1
arrFiles(i,1) = dateVar
WScript.echo i & "." & "M:" & monthVar & " Y:" & yearVar
WScript.echo i & "." & strFileName & " : " & arrFiles(i,1) & " : " & dateVar
i=i+1
Next
For Each aItem In pCurrentDir.SubFolders
'wscript.Echo aItem.Name & " passing recursively"
getInfo(aItem)
Next
End Sub
Function GetDatePictureTaken(strFileName, strDir)
Set objShell = CreateObject ("Shell.Application")
Set objCurrFolder = objShell.Namespace(strDir)
'wscript.Echo cstr(objCurrFolder.GetDetailsOf(strFileName, 12))
strFileNameDate = cstr(objCurrFolder.GetDetailsOf(strFileName, 12))
strFileNameDate = CleanNonDisplayableCharacters(strFileNameDate)
arrDate = split(strFileNameDate, "/")
'''FAILS HERE WITH A SUBSCRIPT OUT OF RANGE ERROR SINCE IT GETS NULL VALUES BACK FROM THE GET DETAILS OF FUNCTION'''
monthVar = arrDate(0)
yearVar = arrDate(1)
dayVar = arrDate(2)
GetDatePictureTaken = monthVar & "\" & dayVar & "\" & yearVar
End Function
Function CleanNonDisplayableCharacters(strInput)
strTemp = ""
For i = 1 to len(strInput)
strChar = Mid(strInput,i,1)
If Asc(strChar) < 126 and not Asc(strChar) = 63 Then
strTemp = strTemp & strChar
End If
Next
CleanNonDisplayableCharacters = strTemp
End Function
The "Subscript out of range" error when accessing arrDate(0) is caused by arrDate being empty (UBound(arrDate) == -1). As a Split on a non-empty string will return an array, even if the separator is not found, and an attempt to Split Null will raise an "Invalid use of Null" error, we can be sure that strFileNameDate is "".
Possible reason for that:
The index of "Date Picture Taken" is 25 (XP) and not 12 (Win 7) - or whatever came to Mr. Gates' mind for Win 8.
The DPT property is not filled in.
Your cleaning function messed it up.
You have to test for strFileNameDate containing a valid date and decide where to put the files without a valid DPT.
P.S. Instead of doing the recursive loopings, you should consider to use
dir /s/b path\*.jpg > pictures.txt
and to process that file.

Resources