exception handling and skip text messages - vbscript

My script is basically the same as last time, but there are some bonus features I'm having problems with.
Is there something similar to exception handling in VBScript? I've read about it and I'm not to sure and is there a way if the script gets canceled for not existing path folders, to create them and continue/restart?
Is there a way how I'm able to skip (They've to be there, but it would be fancy if I could be able to skip them.) at the beginning of the script all these text messages and how is it done?
Here's the code I've got so far:
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)) & "_" & Pad(Hour(f.DateCreated)) & _
Pad(Minute(f.DateCreated)) & Pad(Second(f.DateCreated))
newname = fso.GetBaseName(f) & "_" & created & "." & fso.GetExtensionName(f)
WScript.Echo "Aktuelles File, welches gerade kopiert wird: " & newname
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"
How do I have to implement "On Error Resume Next"?
I've done something like this right now and I'm not to sure if it's correct:
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists("C:\test") Then
On Error Goto 0
Dim StartFolder, TargetFolder
StartFolder = "C:\test"
TargetFolder = "C:\test1"
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)) & "_" & Pad(Hour(f.DateCreated)) & Pad(Minute(f.DateCreated)) & Pad(Second(f.DateCreated))
newname = fso.GetBaseName(f) & "_" & created & "." & fso.GetExtensionName(f)
If UCase(FSO.GetExtensionName(f.name)) = "JPG" Then
f.Copy fso.BuildPath(dst, newname), True
WScript.Echo "Ich kopiere: " & StartFolder & "\" & f.name & " nach " & TargetFolder & "\" & newname
End If
Next
'Recurse into subfolders.
For Each sf In fldr.SubFolders
CopyFiles sf, dst
Next
End Sub
CopyFiles fso.GetFolder("C:\test"), "C:\test1"
End If
On Error Resume Next
f.Copy fso.BuildPath(dst, newname), True
If Err Then
WScript.Echo Err.Description & " [0x" & Hex(Err.Number) & "]"
End If
On Error Goto 0

If I understood your question correctly, error handling should not be required for what you're trying to do. To make sure that a folder exists before doing something with it, you can simply use the FolderExists method:
If fso.FolderExists("C:\some\folder") Then
'do stuff
End If
However, if for some reason you must use error handling, it can be enabled with the statement On Error Resume Next and disabled with the statement On Error Goto 0. While error handling is enabled you can detect errors by checking the state of the Err object.
A very simple error handling routine might look like this:
On Error Resume Next
f.Copy fso.BuildPath(dst, newname), True
If Err Then
WScript.Echo Err.Description & " [0x" & Hex(Err.Number) & "]"
End If
On Error Goto 0
Error handling suppresses all runtime error messages, so you should keep it as local as possible. Having error handling enabled on a broader scope bears the risk of errors going unnoticed, causing unexpected/undesired behavior for instance due to variables being not initialized or retaining an obsolete value.
If you have several subsequent statements that could fail make sure you add error handling routines for each and clear the Err object after each statement:
On Error Resume Next
Set wmi = GetObject("winmgmts://./root/cimv2")
If Err Then
WScript.Echo Err.Description & " [0x" & Hex(Err.Number) & "]"
End If
Err.Clear
Set proc = wmi.ExecQuery("SELECT * FROM Win32_Process")
If Err Then
WScript.Echo Err.Description & " [0x" & Hex(Err.Number) & "]"
End If
Err.Clear
'...
On Error Goto 0

Related

create folder(trusted), copy of MDE and shortcut

I have put together a script that I think will work, but the only code I know is some VBA. Never tried to create a vbscript before, so my apologies if some errors are obvious, but pointers and corrections would be appreciated.
I am hoping I can give users in my company a link to this script and have them run it. It will create a folder on their C Drive, make it a trusted location, copy a database frontend from the server into it and create a shortcut on their desktop linking to the new file. (I'm hoping the file will auto-update when a new version is made - I think that bit works though).
The code comes from various sources, including my own addled mind but would I need to download Visual Studio to test this? Slightly concerned as it includes creating a registry key and I don't know how to stop the code if it all goes horribly wrong. I don't even know how to break a loop (although I think I read somewhere you need to hit Esc twice). Any tips on how to signify which sub is the main one to run on start would be good too.
EDIT : Code has been amended to my end result incase it is of use to others. Please use with caution. The 'update' vbs deletes the folder created on the local drive.
'FrontEnd Setup
call CreateTrustedFolder
'Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
'Const HKEY_LOCAL_MACHINE = &H80000002
'Const HKEY_USERS = &H80000003
'Const HKEY_CURRENT_CONFIG = &H80000005
Dim lclFolder
Dim blnUpdate
Sub CreateTrustedFolder()
On error resume next
Call RunAdmin
Call FolderFileShortcut
Call CreateReg
if err then
MsgBox "The following error has occurred " & Err & " " & Err.Description
exit Sub
end if
End Sub
'Run as Administrator
Sub RunAdmin()
On error resume next
If Not WScript.Arguments.Named.Exists("elevate") Then
CreateObject("Shell.Application").ShellExecute WScript.FullName _
, WScript.ScriptFullName & " /elevate", "", "runas", 1
WScript.Quit
End If
if err then
MsgBox "The following error has occurred " & Err & " " & Err.Description
exit Sub
end if
End Sub
'Check if folder exists, add file and desktop shortcut
Sub FolderFileShortcut()
On error resume next
Dim oWS
Dim FSO
Dim svrFolder
Dim myShortcut
Dim strLocalDB
Dim strServerDB
Dim strUpdate
Dim strIcon
Dim objFile
Dim counter
Set oWS = WScript.CreateObject("WScript.Shell")
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
svrFolder = "\\192.168.1.2\DeptFolder\DatabaseFolder\Auto-Update"
lclFolder = "C:\Program Files\Orrible Database"
If (FSO.FolderExists(lclFolder)) Then
oWS.run "icacls """ & lclFolder & """ /reset /grant:r Users:(W) /t" '/T required for existing folders
FSO.DeleteFolder lclFolder
blnUpdate = True
end if
If Not (FSO.FolderExists(svrFolder)) Then
msgbox "Unable to connect to Location Server", vbCritical, "Installation Failed"
WScript.Quit
End If
For Each objFile in FSO.Getfolder(svrFolder).Files
if LCase(FSO.GetExtensionName(objFile.name)) = LCase("mde") then
counter = counter + 1
strServerDB = FSO.GetFileName(objFile)
end if
Next
If strServerDB = "" or counter <> 1 then
msgbox "Unable to locate the Front End" & strServerDB & "-" & counter, vbCritical, "Installation Failed"
wScript.Quit
end if
strLocalDB = "Co Database.mde"
strUpdate = "DB_UpdateCheck.vbs"
strIcon = "Frontend Update.ico"
FSO.CreateFolder(lclFolder)
oWS.run "icacls """ & lclFolder & """ /grant Users:(OI)(CI)F /t" '/T required for existing folders
FSO.CopyFile svrFolder & "\" & strUpdate, lclFolder & "\" & strUpdate, True
FSO.CopyFile svrFolder & "\" & strServerDB, lclFolder & "\" & strLocalDB, True
FSO.CopyFile svrFolder & "\" & strIcon, lclFolder & "\" & strIcon, True
strDesktop = oWS.SpecialFolders("Desktop")
set myShortcut = oWS.CreateShortcut(strDesktop + "\New Database.lnk")
myShortcut.TargetPath = lclFolder & "\" & strUpdate
myShortcut.WindowStyle = 1
myShortcut.IconLocation = lclFolder & "\" & strIcon
myShortcut.WorkingDirectory = strDesktop
myShortcut.Save
if err then
MsgBox "The following error has occurred " & Err & " " & Err.Description
exit Sub
end if
End Sub
Sub CreateReg()
On error resume next
Dim objRegistry 'registry object
Dim strDescription 'Description of the Trusted Location
Dim strParentKey 'Registry location of Application
Dim strNewKey 'strParentKey and myFolder
Dim oWS 'WSH shell object
strDescription = "DB Folder"
strParentKey = "Software\Microsoft\Office\15.0\Access\Security\Trusted Locations"
strNewKey = strParentKey & "\" & strDescription & "\"
Set objRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
'objRegistry.GetStringValue HKEY_CURRENT_USER, strParentKey & "\" & strDescription
If Not objRegistry.EnumKey(HKEY_CURRENT_USER, strNewKey) = 0 then '0=true
objRegistry.CreateKey HKEY_CURRENT_USER, strNewKey
objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Path", lclFolder
objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Description", strDescription
End if
If not blnUpdate = True then
msgbox "The Database is now available from your desktop", vbInformation, "Setup Complete"
Else
msgbox "The update is now complete."
End if
if err then
MsgBox "The following error has occurred " & Err & " " & Err.Description
exit Sub
end if
End Sub
There is also a separate Update vbs which is what runs when the link is clicked. This checks to see if the 'created date' of the database on the server is newer than that on the local drive. The new DB name MUST NOT be the same as the one it is replacing. It might run a little fast, but this is as far as I have taken this.
Call CheckForUpdate
Sub CheckForUpdate()
On Error Resume Next
Dim FSO
Dim oWS
Dim svrFolder
Dim lclFolder
Dim svrFail
Dim strLocalDB
Dim strServerDB
Dim lclDate
Dim svrDate
Dim strFileName
Dim intDBcount
Dim fCheck
Set oWS = WScript.CreateObject("WScript.Shell")
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
svrFolder = "\\192.168.1.2\DeptFolder\DatabaseFolder\Auto-Update"
lclFolder = "C:\Program Files\Orrible Database"
strLocalDB = "Co Database.mde"
If Not (FSO.FolderExists(svrFolder)) Then
msgbox "Unable to connect to Location Server", vbCritical, "Update Check Failed"
svrFail = True
End If
If Not svrFail = True Then
For Each fCheck in FSO.GetFolder(svrFolder).Files
If Ucase(Right(fCheck.Name, 3)) = "MDE" Then
intDBcount = intDBcount + 1
strServerDB = fCheck.name
End If
Next
If Not intDBcount = 1 Then
MsgBox "Please inform the Administrator that there is a problem with the Automated Update System.", _
vbCritical, "Update Failed (" & intDBcount & ")"
svrFail = True 'not quit - need to see if old version available
End If
End If
If Not (FSO.FolderExists(lclFolder)) Then
If svrFail = True Then 'If no lcl folder or server
If Not intDBcount = 1 then WScript.Quit
msgbox "You are unable to use the Database." & vbcrlf & _
"Please try again when you have access to the Location Server.", _
vbcritical, "Database Not Installed"
WScript.Quit
Else 'If no lclfolder, get it from svr
'Do normal initial install
oWS.Run svrFolder & "\" & "DB_Install.vbs", 1, True
WScript.Quit
End If
Else
If svrFail = True Then 'If lcl folder, but no svr
'open db
oWS.Run CHR(34) & lclFolder & "\" & strLocalDB & CHR(34)
WScript.Quit
Else 'If lcl folder and svr access, check for update.
lclDate = fso.getfile(lclFolder & "\" & strLocalDB).DateCreated
svrDate = fso.getfile(svrFolder & "\" & strServerDB).DateCreated
If lclDate < svrDate Then 'Update available
intMsg = MsgBox("An update is available - Do you wish to update now?", vbQuestion + vbYesNo, "Update Found")
If intMsg = vbYes Then
oWS.Run svrFolder & "\" & "DB_Install.vbs", 1, True ',1,true should pause the code until install closes
oWS.Run CHR(34) & lclFolder & "\" & strLocalDB & CHR(34)
WScript.Quit
Else
oWS.Run CHR(34) & lclFolder & "\" & strLocalDB & CHR(34)
WScript.Quit
End If
Else
oWS.Run CHR(34) & lclFolder & "\" & strLocalDB & CHR(34)
WScript.Quit
End If
End If
End If
If err Then
MsgBox "The following error has occurred " & Err & " " & Err.Description
Exit Sub
End If
End Sub

How to recursively rename files in subfolders using VBScript

I wrote this script to organize my video library. To keep consistent naming standards, I want a method to rename files in subfolders. The problem with the code below is that when I set fso = Nothing at the end, it breaks the FileSystemObject, and I cannot figure out a way to recall it with the standard For Each Next statement. In the meantime, I've turned it off, but if I step through all of the folders to rename, the appending numbers continue to ascend with each file regardless of folder. Ideally, this is the result I'm looking for:
(Let's use a TV Show as example)
Folder: Breaking Bad
Subfolder: Season 1
Files: Breaking S01E01, Breaking S01E02, Breaking S01E03
Subfolder: Season 2
Files: Breaking S02E01, Breaking S02E02, Breaking S02E03
Current results:
Folder: Breaking Bad
Subfolder: Season 1
Files: Breaking S01E01, Breaking S01E02, Breaking S01E03
Subfolder: Season 2
Files: Breaking S02E04, Breaking S02E05, Breaking S02E06
Note: I set up logging, so you can ignore all AddLog lines.
Option Explicit
Dim fso, oFolder, oFile, iCount, strSeries, strSeason, folder, fsoSubFolders, msg, objLogFile, strLogFile, sMsg
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(fso.GetAbsolutePathName("."))
Set fsoSubFolders = oFolder.SubFolders
strLogFile = oFolder & "\" & "Rename.log"
iCount = 0
CreateLogFile
AddLog(sMsg)
'CREATE LOG FILE ROUTINE
Sub CreateLogFile()
Set objLogFile = Nothing
If fso.FileExists(strLogFile) Then
Set objLogFile = fso.GetFile(strLogFile)
Set objLogFile = fso.OpenTextFile(strLogFile, 8, True)
AddLog "|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||"
AddLog "|||||||||||||||||||||||||||||||||||||||||| NEW LOG FILE EVENT STARTED |||||||||||||||||||||||||||||||||||||||||||"
AddLog "|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||"
AddLog "Preparing log file."
AddLog "Log File found."
AddLog "Appending to existing Log File: " & strLogFile
Else
Set objLogFile = fso.CreateTextFile(strLogFile)
objLogFile.Close
Set objLogFile = fso.OpenTextFile(strLogFile, 2, True)
AddLog "|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||"
AddLog "|||||||||||||||||||||||||||||||||||||||||| NEW LOG FILE EVENT STARTED |||||||||||||||||||||||||||||||||||||||||||"
AddLog "|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||"
AddLog "Preparing log file."
AddLog "Log File found not."
AddLog "Creating new Log File: " & strLogFile
End If
End Sub
'APPEND TO LOG ROUTINE
Sub AddLog(sMsg)
If Not ObjLogFile Is Nothing Then
If sMsg = "" Then
objLogFile.WriteLine(sMsg)
Else
objLogFile.WriteLine( Date & " - " & Time & ": " & "|" & sMsg)
End If
End If
End Sub
'SEARCH SUBFOLDERS
AddLog "||||||||||||||||||||||||||||||||||||||||||||||||| START SCRIPT ||||||||||||||||||||||||||||||||||||||||||||||||||"
For Each folder in fsoSubFolders
AddLog " "
AddLog "Working folder: " & folder
msg = MsgBox("CAUTION!" & vbCrLf & vbCrLf & _
"You are about to rename files in folder: " & folder.Name & ". " & _
"Do you want to continue?", vbYesNo, "Renaming Service")
If msg = vbYes Then
GetSeries
Else
AddLog "Skipping folder: " & folder
End If
Next
'GET SERIES NAME
Sub GetSeries()
strSeries = InputBox("ENTER SERIES NAME:" & vbCrlf & "(e.g.: Breaking Bad, The Walking Dead, Firefly, etc)", "Rename Series")
If strSeries = "" Then
AddLog "Exiting script before complete."
QuitApp()
ElseIf IsBlank(strSeries) = True Then
AddLog "ERROR: No value entered, restarting."
MsgBox "ERROR!" & vbCrLf & vbCrLf & "Field cannot be blank. Try again."
GetSeries
ElseIf IsNumeric(strSeries) Then
AddLog "ERROR: Value cannot be numeric, restarting."
MsgBox "ERROR!" & vbCrLf & vbCrLf & "Field does not support numeric values. Try again."
GetSeries
Else
AddLog "Series Title Set: " & strSeries
GetSeason
End If
End Sub
'GET SEASON NAME
Sub GetSeason()
strSeason = InputBox ("ENTER SEASON:" & vbCrlf & "(e.g.: 01, 02, 03, etc)", "Rename Season")
If strSeason = "" Then
AddLog "Exiting script before complete."
QuitApp()
ElseIf IsBlank(strSeason) = True Then
AddLog "ERROR: No value entered, restarting."
MsgBox "ERROR!" & vbCrLf & vbCrLf & "Field cannot be blank. Try again."
GetSeries
ElseIf Not IsNumeric(strSeason) Then
AddLog "ERROR: Value cannot be non-numeric, restarting."
MsgBox "ERROR!" & vbCrLf & vbCrLf & "Field does not support non-numeric values. Try again."
GetSeason
Else
AddLog "Season Title Set: " & strSeason
AddLog "================================================================================================================="
Rename
End If
End Sub
'CHECK FOR BLANK VALUES
Function IsBlank(Value)
If IsEmpty(Value) or IsNull(Value) Then
IsBlank = True
ElseIf IsObject(Value) Then
If Value Is Nothing Then
IsBlank = True
End If
Else
IsBlank = False
End If
End Function
'RENAME FILES
Sub Rename()
For Each oFile In folder.Files
iCount = iCount + 1
If oFile.Name <> "Rename.vbs" Then
AddLog "Old file name: " & oFile.Name
If iCount = 1 Or iCount = 2 Or iCount = 3 Or iCount = 4 Or iCount = 5 Or iCount = 6 Or iCount = 7 Or iCount = 8 Or iCount = 9 Then
oFile.Name = strSeries & " S" & strSeason & "E0" & iCount & "." & fso.GetExtensionName(oFile.Name)
AddLog "New file name: " & oFile.Name
Else
oFile.Name = strSeries & " S" & strSeason & "E" & iCount & "." & fso.GetExtensionName(oFile.Name)
AddLog "New file name: " & oFile.Name
End If
End If
Next
Set oFile = Nothing
Set folder = Nothing
'Set fso = Nothing
End Sub
'PREMATURE QUIT
Sub QuitApp()
AddLog "|||||||||||||||||||||||||||||||||||||||||||||||||| END SCRIPT |||||||||||||||||||||||||||||||||||||||||||||||||||"
WScript.Quit()
End Sub
The file system object is needed for each access to your disk. Because of that you cannot set it to nothing as long as you still need to handle files. So in your case you can only set it to nothing at the end.
The reason why the numbering is wrong is a different one however.
Icount is a global variable and only set to 0 at the beginning of the script.
As within each season folder the episodes start at 1 again you also have to reset the icount whenever you enter one of these folders.
Set it to 0 at the first line of the rename function (before the for) and it should work.
One thing to keep in mind is that the folder.files will give you the current list of episodes sorted alphabetically. So your renaming will only work if the episodes are named in a format so they are in the right order when sorted alphabetically.

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

copy the files with creation date range using VBS (in Sub folder files also)

I tried with this link
copy files between a specified date range
but i am able to copying only root directory
please any one help me
Here you go. Please note that this can potentially create empty directories because it will create a directory and then check to see if each file falls within the specified date range or not. If no files do, the directory will remain empty.
Obviously, you can comment out or delete the WScript.Echo lines. They are for troubleshooting only.
Option Explicit
dim objFSO, strSource, strTarget
set objFSO = CreateObject("Scripting.FileSystemObject")
strSource = "c:\Folder1\"
strTarget = "c:\Copy of Folder1\"
call RecurseCopy(strSource, strTarget, True, #04/15/2012 00:00:01 AM#, #04/16/2012 00:00:01 AM#)
' // Recursively copy all files and folders
Sub RecurseCopy(strSource, strTarget, blnCopySubfolders, dBeginDate, dEndDate)
dim objSource, objTarget
WScript.Echo "Begin RecurseCopy" & vbcrlf & vbcrlf & _
"strSource: " & strSource & vbcrlf & _
"strTarget: " & strTarget
set objSource = objFSO.GetFolder(strSource)
If objFSO.FolderExists(strTarget) = False Then
Wscript.Echo "Now going to create folder: " & strTarget
objFSO.CreateFolder(strTarget)
End If
set objTarget = objFSO.GetFolder(strTarget)
Dim file
for each file in objSource.files
If file.DateCreated => dBeginDate AND file.DateCreated =< dEndDate Then
Wscript.Echo "Copying file: " & file.path & " to " & objTarget.Path
file.Copy objTarget.Path & "\" & file.name
Else
WScript.Echo "File will not be copied because the DateCreated is not within the specified range." & vbcrlf & vbcrlf & _
File.Path & " " & file.DateCreated
End If
next
If blnCopySubfolders = True Then
' ** For each subfolder of current dir, copy files to target and recurse its subdirs
Dim subdir
for each subdir in objSource.subfolders
call RecurseCopy(objSource.Path & "\" & subdir.Name, objTarget.Path & "\" & subdir.Name, True, dBeginDate, dEndDate)
Next
End If
End Sub

How do I know when a file has been modified in a VBA Macro?

Is there a way to watch a file in VBA (which is essentially VB6), so that I know when the file has been modified? -- similar to this only I don't want to know when a file is unused, just when its modified.
The answers I've found have recommended using "FileSystemWatcher" and the Win32 API "FindFirstChangeNotification". I can't figure out how to use these though, any idea?
Okay, I put together a solution that is able to detect file system changes, in VBA (VB6).
Public objWMIService, colMonitoredEvents, objEventObject
'call this every 1 second to check for changes'
Sub WatchCheck()
On Error GoTo timeout
If objWMIService Is Nothing Then InitWatch 'one time init'
Do While True
Set objEventObject = colMonitoredEvents.NextEvent(1)
'1 msec timeout if no events'
MsgBox "got event"
Select Case objEventObject.Path_.Class
Case "__InstanceCreationEvent"
MsgBox "A new file was just created: " & _
objEventObject.TargetInstance.PartComponent
Case "__InstanceDeletionEvent"
MsgBox "A file was just deleted: " & _
objEventObject.TargetInstance.PartComponent
Case "__InstanceModificationEvent"
MsgBox "A file was just modified: " & _
objEventObject.TargetInstance.PartComponent
End Select
Loop
Exit Sub
timeout:
If Trim(Err.Source) = "SWbemEventSource" And Trim(Err.Description) = "Timed out" Then
MsgBox "no events in the last 1 sec"
Else
MsgBox "ERROR watching"
End If
End Sub
Copy and paste this sub near the above, it is called automatically if needed to initialize the global vars.
Sub InitWatch()
On Error GoTo initerr
Dim watchSecs As Integer, watchPath As String
watchSecs = 1 'look so many secs behind'
watchPath = "c:\\\\scripts" 'look for changes in this dir'
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery _
("SELECT * FROM __InstanceOperationEvent WITHIN " & watchSecs & " WHERE " _
& "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
& "TargetInstance.GroupComponent= " _
& "'Win32_Directory.Name=""c:\\\\scripts""'")
MsgBox "init done"
Exit Sub
initerr:
MsgBox "ERROR during init - " & Err.Source & " -- " & Err.Description
End Sub
You should consider using a WMI temporary event consumer to watch the file, along the lines suggested here but narrowing it down to a specific file instead of a folder
(This is assuming you can't just keep an eye on the file's Modified Date property..)
Have a look here. The page has a "Watch Directory Demo" VB sample, by Bryan Stafford.
I take it into vb6,run,display:ERROR watching.

Resources