Here is the problem:
I have a folder with many text files. I want to find the file I need to parse; however, it has a different name each time so I cannot use the file name. What I know about it is that it is always 39KB (although marginally different each time, so I check for >39000 and <40000). However, there are often several files of that same size in the folder, and I would like to select the MOST recently modified one.
What I have:
If fNewest = "" Then
Set fNewest = objFile
ElseIf fNewest.DateLastModified < objFile.DateLastModified Then
Set fNewest = objFile
End If
If (objFile.Size > 39000 and objFile.Size < 40000) Then
Msgbox fNewest
End If
While fNewest is returning the path to the file I want (the 39Kb file that was most recentl modified), Msgbox is being called 4 times (which is the number of occurances of a file that is 39Kb in that folder). Does anyone know how I can modify this code to correct this, or a better way to run this check?
My ultimate coal is to have a condition statement(s) as above so Msgbox is replaced with the call to the specific function that takes that file and parses it.
Thanks.
Your nesting is off. The MsgBox should be outside the loop with which you iterate over the files in your folder, and the assignment should be inside the conditional that checks the file size. Try this:
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f In fso.GetFolder("...").Files
If f.Size > 39000 and f.Size < 40000 Then
If IsEmpty(newest) Then
Set newest = f
ElseIf newest.DateLastModified < f.DateLastModified Then
Set newest = f
End If
End If
Next
If Not IsNull(newest) Then MsgBox newest.Name
Dim newest, fso
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f In fso.GetFolder(".").Files
If f.Size > 39000 and f.Size < 40000 Then
If IsEmpty(newest) Then
Set newest = f
ElseIf newest.DateLastModified < f.DateLastModified Then
Set newest = f
End If
End If
Next
If Not IsEmpty(newest) Then MsgBox newest.Name
(I just replace IsNull with IsEmpty)
Related
This script collects all files in a folder and renames the files by appending the number of lines to the file name. All files are .txt files. The method (since fso.MoveFile and fso.DeleteFile are too particular, generating permissions errors) is to
create the text files,
then create a collection of the files in the folder,
then copy each file into the same folder with a new name, and
finally to delete the original file that was copied.
The script works ok, unless there are no empty text files in the collection. What happens is, the collection gets rebuilt with the new files and the script once again renames the files. I know I can prevent this by checking each file for the existence of certain repeating character strings, but I'd like to know what's happening? Why does the script rebuild the file collection and run through them again renaming each one? This continues on until I kill the process.
Another interesting factoid is, if I happen to trap an empty text file, my message is displayed and the script stops there, but has still reprocessed the first file in the collection a second time. Note that the empty file just happens to be the last one in the collection, but the first filed is once again processed.
So, by design a created text file named 'ab0.txt' gets renamed to 'ab0-15.txt' since it has 15 lines of text in it. What happens is this newly renamed file looks like 'ab0-15-15-15-15-15-15-15-15-15-15.txt'
Questions: What's going on? And is there a better and more efficient way to accomplish this objective?
Here's the code pertinent to the issue:
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(strSaveTo)
Set colFiles = oFolder.Files
' Call Sub to copy and rename
ChangeFileName colFiles
MsgBox("File renaming complete.")
' Exit code
Sub ChangeFileName(collectionSet)
Const ForReading = 1
Dim oFile
For Each oFile In collectionSet
Set LineCnt = fso.OpenTextFile(oFile, ForReading)
If oFile.Size = 0 then
'if this msg is not included, weird things happen
MsgBox("The file named " & oFile & _
" is empty.You may want to verify and manually delete it.")
'[I had some code in here to delete the empty file, but nothing worked]
Else
Do While LineCnt.AtEndOfStream <> True
LineCnt.SkipLine
Loop
lineVar = lineCnt.Line-1
strNewFile = strSaveTo & Left(oFile.name, Len(oFile.name)-4) & _
"-" & lineVar & ".txt"
fso.CopyFile oFile, strNewFile
LineCnt.Close
fso.DeleteFile oFile, True
End If
Next
End Sub
I've heard anecdotal evidence that the Files collection is "live", meaning that newly created files will be added to the collection and iterated over, but I can't find any documentation that says one way or the other. In any case, it's probably a good idea to copy the File objects in the collection to an array first before processing them:
Dim oFile
Dim fileArray()
Dim i
ReDim fileArray(collectionSet - 1)
i = 0
For Each oFile in collectionSet
Set fileArray(i) = oFile
i = i + 1
Next
For Each oFile In fileArray
' Count lines and rename
Next
It seems that collectionSet is the collection of files in the folder that you are trying to modify. The problem is that with each pass through the for-each loop you are adding files to this folder, some of which are fed back into the loop. What you need to do is the find a way to take a snapshot of the folder before you try to iterate over it. The way to do this would be to replace the folder collectionSet by a collection of strings which are the names of the files before you iterate over it, and modify your code to open the files by their name (instead of via a file object). That way the collection won't be expanding while you iterate over it.
You should create your vars in the scope they are used (e.g. your
file/folder objects are used in the sub.
Always explicit(ly) declare your vars.
You don't need to copy the file and rename it then do the delete.
Just rename it with the FileObject.Name property.
Here is an example:
Option Explicit 'always declare your vars!
Dim strFolder: strFolder = "c:\temp\Rename Test"
Dim strExtension: strExtension = "txt"
' Call Sub to rename the files in the folder
ChangeFileName strFolder, strExtension
Sub ChangeFileName(strFolder, strExtension)
Const ForReading = 1
Dim FSO: set FSO = CreateObject("Scripting.FileSystemObject")
Dim objFolder: set objFolder = FSO.GetFolder(strFolder)
Dim colFiles: set colFiles = objFolder.Files
Dim objFile
Dim intCount
Dim strFileName
Dim objTextStream
For Each objFile In colFiles
msgbox "File: " & objfile.path & vbcrlf & FSO.GetExtensionName(objFile.path)
if UCase(FSO.GetExtensionName(objFile.Path)) = UCase(strExtension) and _
objFile.Size > 0 then
'set LineCnt = FSO.OpenTextFile(objFile, ForReading)
set objTextStream = objFile.OpenAsTextStream(ForReading,-2)
intCount = 0
strFileName = objFile.Name
Do While objTextStream.AtEndOfStream <> True
intCount = intCount + 1
objTextStream.ReadLine
Loop
objTextStream.Close
objFile.Name = FSO.GetBaseName(objFile.Path) & "-" & _
intCount & "." & FSO.GetExtensionName(objFile.Path)
end if
Next
End Sub
What I wish to do is:
Copy files from a variety of sub-folders under a single main folder to a destination folder.
Three options when copying:
If no file in destination folder exists then copy.
If file exists, copy over if filesize is larger than destination file.
If file exists and both are the same filesize compare date/time and copy over if most recent.
Here is my pseudocode so far:
Dim filesys, strSourceFile, strDestFolder, strDestFile
Set filesys = CreateObject("Scripting.FileSystemObject")
strSourceFile = S:\SoCal\Section_2\*\Autogen\texture\*.agn
strDestFolder = F:\ADDON_SCENERY\simwestSOCAL\texture
strDestFile = F:\ADDON_SCENERY\simwestSOCAL\texture\*.agn
COPY each file in strSourceFolder
If IsEmpty (SourceFile, DestFolder)
Else If (SourceFile FileSize > DestFile)
Else If (SourceFile DateTime > DestFile DateTime)
Then 'keep/copy most recent file
End if
Am I on the right track?
Do I need to add a Loop?
Can one compare file sizes? All my research has found nothing yet on this.
Can I compare Date and Time against files?
As an update to my original post... (hope I am following forum rules correctly),
I have spent the last several weeks non-stop just reading-reading-reading and testing-failure-testing. I am happy to say (and a little proud), that I have completed my very first script... and it appears to work as planned but for just one file. I now need to convert this to work on all files inside my 'sourcefolder'.
I am a bit "brain dead" from this so any direction on converting this would be most appreciated. I know I need loops but what type and where? Do I rename everything referring to a file to a folder or use '*.txt' for files? In the meantime I will keep studying.
Here is my script (yea, lot's of MsgBox's so I could follow along the script path):
dim dFolder
dFolder = "S:\Scripting Workfolder\destfolder\"
dim dFile
dFile= "S:\Scripting Workfolder\destfolder\File 1.txt"
dim sFile
sFile = "S:\Scripting Workfolder\sourcefolder\File 1.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
'Check to see if the file already exists in the destination folder
If Not fso.FileExists(dFile) Then
MsgBox "File does not exist - will copy over to dFolder"
fso.CopyFile sFile, dFolder, true
Elseif fso.FileExists(dFile) Then
MsgBox "File already exist in destination folder determine largest"
ReplaceIfLarger sFile, dFile
End If
Sub ReplaceIfLarger(sFile, dFile)
const overwrite_existing = true
dim objFSO
set objFSO = createobject("Scripting.FileSystemObject")
dim objSourceFile
set objSourceFile = objFSO.GetFile(sFile)
'dim kbSourceSize
kbSourceSize = objSourceFile.size
dim objTargetFile
set objTargetFile = objFSO.GetFile (dFile)
'dim kbTargetSize
kbTargetSize = objTargetFile.size
If kbSourceSize > kbTargetSize Then
MsgBox "Source file is LARGER and will overwrite to dest folder"
objFSO.CopyFile objSourceFile.Path, objTargetFile.Path, overwrite_existing
ElseIf kbSourceSize < kbTargetSize Then
MsgBox "Source file is smaller - Will not overwrite to dest folder"
Else
ReplaceIfNewer sFile, dFile
End If
End Sub
Sub ReplaceIfNewer(sFile, dFile)
MsgBox "Both files exist and are the same size. Keep newest file"
const overwrite_existing = true
dim objFSO
set objFSO = createobject("Scripting.FileSystemObject")
dim dtmSourceFile
set dtmSourceFile = objFSO.GetFile(sFile)
dim dtmTargetFile
set dtmTargetFile = objFSO.GetFile(dFile)
If (dtmSourceFile.DateLastModified > dtmTargetFile.DateLastModified) then
MsgBox "Source File is Newer than Target File - Overwrite Target file"
objFSO.CopyFile dtmSourceFile.Path, dtmTargetFile.Path, overwrite_existing
Else
MsgBox "Source File is Older than Target File - Will not overwrite file"
End If
End Sub
Basically I am trying to write a script to delete files after a certain filename, so based on the below file list
FILE_000001_FULL.ZIP
FILE_000002_FULL.ZIP
FILE_000003_FULL.ZIP
FILE_000004_FULL.ZIP
FILE_000005_FULL.ZIP
FILE_000006_DELTA.ZIP
FILE_000007_DELTA.ZIP
FILE_000008_FULL.ZIP
Everything up until FILE_000005_FULL.ZIP would be deleted. The files are created using a tool and will be sorted by file name, so highest number first. Basically need the 2 latest FULL files kept and the DELTA's (if any) between them. I hope that makes sense.
So far, this is what I have, but just loops constantly, not just until it finds the 2 latest fulls.
Dim fso, folder, files, ToDel, sfolder
Set fso = CreateObject("Scripting.FileSystemObject")
sFolder = ("C:\MDS")
Set ToDel = fso.CreateTextFile ("C:\MDS\FileList.txt", True)
Set folder = fso.GetFolder(sFolder)
set files = folder.files
For each folderIDX In files
ToDel.WriteLine(folderidx.Name)
Next
ToDel.close
Dim arrFileLines()
i = 0
Set ObjFile = FSO.OpenTextFile("C:\MDS\FileList.txt", 1)
Do Until objFile.AtEndOfStream
Redim Preserve arrFileLines(i)
arrFileLines(i) = objFile.ReadLine
i = i + 1
Loop
ObjFile.Close
s = 0
Do While s < 2
For l = Ubound(arrFileLines) to LBound(arrFileLines) Step -1
For Each strLine in arrFileLines
IF InStr(strLine, "FULL") <> 0 Then
wscript.echo "Found Full!!!!"
wscript.echo strLine, s
s = S + 1
End If
Next
Next
LooP
My thoughts was to delete the lines from the text file, then use this text file to delete the files from the directory.
Hopefully that all makes sense and someone can pass some advice on!
You should be able to do this with two iterations through your folder and without the need/use of a text file. During the first pass, record the numbers assigned to the two latest FULL's. Then, in your second pass, delete any files that are less than your second-highest FULL.
Here's how it might look:
' First pass: Find the two latest FULLs...
For Each File In FSO.GetFolder("c:\mds").Files
' Is this a FULL?
If Right(File.Name, 8) = "FULL.ZIP" Then
' Get the numeric value from the file name (6 digits starting as pos 6)...
intNum = CLng(Mid(File.Name, 6, 6))
' Maintain the two latest FULLs...
If intNum > intMax1 Then
intMax2 = intMax1
intMax1 = intNum
ElseIf intNum > intMax2 Then
intMax2 = intNum
End If
End If
Next
' Second pass: Delete anything prior to the second-latest FULL...
For Each File In FSO.GetFolder("c:\mds").Files
intNum = CLng(Mid(File.Name, 6, 6))
If intNum < intMax2 Then File.Delete
Next
I wrote a simple vbscript to rename files in a particular folder. Specifically to remove particular content from the filname.
The Script I wrote (listed below) runs fine but the highlighted part (second IF-THEN statement) doesn't run. I can't figure out whats wrong with the code. I plan to add more IF-THEN statement to remove particular content from file names.
I'm a novice at this so please be patient with me. Can anyone help?
Set objFS = CreateObject("Scripting.FileSystemObject")
strFolder="C:\Users\Admin2\Downloads\Compressed"
Set objFolder = objFS.GetFolder(strFolder)
For Each strFile In objFolder.Files
strFileName = strFile.Name
If InStr(strFileName,"(2014)") > 0 Then
strNewFileName = Replace(strFileName,"(2014)","")
strFile.Name = strNewFileName
End If
**If InStr(strFileName,"(digital)") > 0 Then
strNewFileName = Replace(strFileName,"(digital)","")
strFile.Name = strNewFileName
End If**
Next
Type prefix fraud detected:
For Each strFile In objFolder.Files
"strFile" should be "objFile". Dangerous extra variable in:
strFileName = strFile.Name
The variable "strFileName" will get stale if you change "objFile.Name". Use a variable to hold the new/desired name instead.
strNewFileName = objFile.Name
Renaming the file twice will loose changes on the way. Modify "strNewFileName" (in steps or all at once:
strNewFileName = Replace(Replace(strNewFileName, "(2014)", ""), "(digital)", "")
; you don't really need the If guard, because Replace won't change strings that don't contain the target).
Check for .FileExists(strNewFileName) before you do the rename.
Can you prove that there are file names that contain "(digita1)" <-- mark the digit 1) exactly? Lower vs. upper case? A nasty blank?
I hope the following code helps
Set objFS = CreateObject("Scripting.FileSystemObject")
strFolder="pathtofolder"
Set objFolder = objFS.GetFolder(strFolder)
For Each objFile In objFolder.Files
ObjFileName = ObjFile.Name
NewFileName = Replace(Replace(ObjFileName,"(2014)",""),"(digital)","")
Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
If fileSystemObject.FileExists(NewFileName) Then
Else
ObjFile.Name = Trim(NewFileName)
End If
Next
I've written a small VBScript to creates a .zip file and then copies the contents of a specified folder into that .zip file.
I copy the files over one by one for a reason (I know I can do the whole lot at once). However my problem is when I try to copy them one by one without a WScript.Sleep between each loop iteration I get a "File not found or no read permission." error; if I place a WScript.Sleep 200 after each write it works but not 100% of the time.
Pretty much I'd like to get rid of the Sleep function and not rely on that because depending on the file size it may take longer to write therefore 200 milliseconds may not be enough etc.
As you can see with the small piece of code below, I loop through the files, then if they match the extension I place them into the .zip (zipFile)
For Each file In folderToZip.Items
For Each extension In fileExtensions
if (InStr(file, extension)) Then
zipFile.CopyHere(file)
WScript.Sleep 200
Exit For
End If
Next
Next
Any suggestions on how I can stop relying on the Sleep function?
Thanks
This is how we do it in VB6. After calling CopyHere on the zip we wait for async compression to complete like this
Call Sleep(100)
Do
Do While Not pvCanOpenExclusive(sZipFile)
Call Sleep(100)
Loop
Call Sleep(100)
Loop While Not pvCanOpenExclusive(sZipFile)
where the helper function looks like this
Private Function pvCanOpenExclusive(sFile As String) As Boolean
Dim nFile As Integer
nFile = FreeFile
On Error GoTo QH
Open sFile For Binary Access Read Lock Write As nFile
Close nFile
pvCanOpenExclusive = True
QH:
End Function
Nice side-effect is that even if zipping fails this will not end up in infinite loop.
The trouble comes when accessing the zip-file when it's closed by zipfldr.dll, that is when pvCanOpenExclusive returns true.
You are correct, CopyHere is asynchronous.
When I do this in a vbscript, I sleep until the count of files in the zip, is greater than or equal to the count of files copied in.
Sub NewZip(pathToZipFile)
WScript.Echo "Newing up a zip file (" & pathToZipFile & ") "
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim file
Set file = fso.CreateTextFile(pathToZipFile)
file.Write Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
file.Close
Set fso = Nothing
Set file = Nothing
WScript.Sleep 500
End Sub
Sub CreateZip(pathToZipFile, dirToZip)
WScript.Echo "Creating zip (" & pathToZipFile & ") from (" & dirToZip & ")"
Dim fso
Set fso= Wscript.CreateObject("Scripting.FileSystemObject")
If fso.FileExists(pathToZipFile) Then
WScript.Echo "That zip file already exists - deleting it."
fso.DeleteFile pathToZipFile
End If
If Not fso.FolderExists(dirToZip) Then
WScript.Echo "The directory to zip does not exist."
Exit Sub
End If
NewZip pathToZipFile
dim sa
set sa = CreateObject("Shell.Application")
Dim zip
Set zip = sa.NameSpace(pathToZipFile)
WScript.Echo "opening dir (" & dirToZip & ")"
Dim d
Set d = sa.NameSpace(dirToZip)
' for diagnostic purposes only
For Each s In d.items
WScript.Echo s
Next
' http://msdn.microsoft.com/en-us/library/bb787866(VS.85).aspx
' ===============================================================
' 4 = do not display a progress box
' 16 = Respond with "Yes to All" for any dialog box that is displayed.
' 128 = Perform the operation on files only if a wildcard file name (*.*) is specified.
' 256 = Display a progress dialog box but do not show the file names.
' 2048 = Version 4.71. Do not copy the security attributes of the file.
' 4096 = Only operate in the local directory. Don't operate recursively into subdirectories.
WScript.Echo "copying files..."
zip.CopyHere d.items, 4
Do Until d.Items.Count <= zip.Items.Count
Wscript.Sleep(200)
Loop
End Sub
You can try accessing the file you've just copied, for example with an "exists" check:
For Each file In folderToZip.Items
For Each extension In fileExtensions
If LCase(oFSo.GetExtensionName(file)) = LCase(extension) Then
zipFile.CopyHere(file)
Dim i: i = 0
Dim target: target = oFSO.BuildPath(zipFile, oFSO.GetFileName(file))
While i < 100 And Not oFSO.FileExists(target)
i = i + 1
WScript.Sleep 10
Wend
Exit For
End If
Next
Next
I'm not sure if target is calculated correctly for this use context, but you get the idea. I'm a bit surprised that this error occurs in the first place... FileSystemObject should be strictly synchronous.
If all else fails, do this:
For Each file In folderToZip.Items
For Each extension In fileExtensions
If LCase(oFSo.GetExtensionName(file)) = LCase(extension) Then
CompressFailsafe zipFile, file
Exit For
End If
Next
Next
Sub CompressFailsafe(zipFile, file)
Dim i: i = 0
Const MAX = 100
On Error Resume Next
While i < MAX
zipFile.CopyHere(file)
If Err.Number = 0 Then
i = MAX
ElseIf Err.Number = xxx ''# use the actual error number!
Err.Clear
WScript.Sleep 100
i = i + 1
Else
''# react to unexpected error
End Of
Wend
On Error GoTo 0
End Sub
The solution we used after much debugging and QA on various windows flavours, including fast and slow machines and machines under heavy CPU load was the following snippet.
Critique and improvements welcome.
We were not able to find a way of doing this without a loop, that is, if you wanted to do some validation or post zipping work.
The goal was to build something that ran reliably on as many windows flavours as possible. Ideally as natively as possible too.
Be advised that this code is still is NOT 100% reliable but its seems to be ~99%. As stable as we could get it with the dev and QA time available.
Its possible that increasing iSleepTime could make it 100%
Points of note:
The unconditional sleep seems to be the most reliable and compatible approach we found
The iSleepTime should not be reduced, it seems the more frequently the loop runs, the higher the probability of an error, seemingly related to the internal operations of the zip/copy process
iFiles is the source file count
The more simplistic the loop was, the better, for example outputting oZippp.Items().Count in the loop caused inexplicable errors that looked like they could be related to file access/sharing/locking violations. We didn't spend time tracing to find out.
It seems on Windows 7 anyway, that the internals of the zipping process use a temp file located in the cwd of the compressed zip folder, you can see this during long running zips by refreshing your explorer window or listing dir with cmd
We had success with this code on Windows 2000, XP, 2003, Vista, 7
You'd probably want to add a timeout in the loop, to avoid infinite loops
'Copy the files to the compressed folder
oZippp.CopyHere oFolder.Items()
iSleeps = 0
iSleepTime = 5
On Error Resume Next
Do
iSleeps = iSleeps + 1
wScript.Sleep (iSleepTime * 1000)
Loop Until oZippp.Items().Count = iFiles
On Error GoTo 0
If iFiles <> oZippp.Items().Count Then
' some action to handle this error case
Else
' some action to handle success
End If
Here is a trick I used in VB; get the length of the zip file before the change and wait for it to change - then wait another second or two. I only needed two specific files but you could make a loop out of this.
Dim s As String
Dim F As Object 'Shell32.Folder
Dim h As Object 'Shell32.Folder
Dim g As Object 'Shell32.Folder
Dim Flen As Long, cntr As Long, TimerInt As Long
Err.Clear
s = "F:\.zip"
NewZipFolder s
Flen = FileLen(s)
Set F = CreateObject("Shell.Application").namespace(CVar(s))
TimerInt = FileLen("F:\MyBigFile.txt") / 100000000 'set the loop longer for bigger files
F.CopyHere "F:\DataSk\DemoData2010\Test.mdf"
Do
cntr = Timer + TimerInt
Do
DoEvents: DoEvents
Loop While cntr > Timer
Debug.Print Flen
Loop While Flen = FileLen(s)
cntr = Timer + (TimerInt / 2)
Do
DoEvents: DoEvents
Loop While cntr > Timer
Set F = Nothing
Set F = CreateObject("Shell.Application").namespace(CVar(s))
F.CopyHere "F:\MynextFile.txt"
MsgBox "Done!"