asked on
Program to automatically compress files

I have a frequent disk space issue on a few servers, whereby logs generated by custom apps are eating up disk space. It usually means manually going in and compressing those files over 3 months.
The logs are required, but I would like to compress them automatically after a specified time period. The folders in question usually have tens of thousands of small files to be archived.
I worked on a vb script to do it, but it went haywire when I set it to run on a folder with thousands of files.
Any recommendations on a program that would take care of this for me? I don't mind paying for it.
arnold
How are the logs managed, does the application generating them rotates them?

The script should only work on one file at a time.
i.e. go through the directory listing and make a decision on whether this file needs to be compressed, if so, run the

Example of zipping files into an existing archive
http://www.tek-tips.com/viewthread.cfm?qid=1231429

Example of script that will go through a directory searching for a file (NOTE: make sure not to run until you modify what it does or this script will delete the office default settings file/template (normal.dot))
http://www.appdeploy.com/messageboards/tm.asp?m=20594&mpage=1&key=偲

i.e. the logic of the script is to get the location of where it needs to look

1) get a listing for the directory (fileobject)
http://www.go4expert.com/forums/showthread.php?t=927
2) The traversing of the directory should be a function to enable you to iterate through the directory if it has a sub directory. i.e. if the loop through the directory listing encounters a sub-directory, you would call the listfiles function with the new directory i.e. myfiles is the starting point. it reaches a subdirectory in myfiles of subfiles
listfiles('myfiles\'+variable.name)
3) the logic within the file search can call function once a decision is made whether to compress the file based on its age or not.
Do not know whether you want to validate that the compression took place at which point the orignal file can be deleted.

Not sure what you have which led to the haywire condition, but you've not included the code for a comment that would correct what you have.
sherryfitzgroup
ASKER
Thanks, my script is attached. It was processing one file at a time, but I think it would run out of resources then, and pop up a lot of errors. It's not my code, but one I got from EE. It works fine in principle on a small folder, but seems to take a long time and throw up errors on folders with a large amount of files.
'#region <File Info>=========================================
' © 2009 Russell Pitcher
'
' NAME	   : Start-LogRotation
' AUTHOR   : Russell Pitcher
' DATE	   : 01/06/2009
' NOTES    :
'
' TEMPLATE : 1.5.0
' VERSION  : 1.0.0
'            | | +-- Bug fix level
'            | +---- Feature update level
'            +------ Major version level
'
'#region <Version History>
' v1.0.0 - 01/06/2009
'	Initial release
''#endregion
'#endregion=================================================

'#region <Initialise>
Option Explicit

'Dimension constants and variables
Const TITLE        = "Log Archiving and Rotation Tool"
Const VERSION      = "1.0.0"
Const MinWshVer    = 5.1

Const ForReading   = 1
Const ForWriting   = 2
Const ForAppending = 8
Const REG_SZ       = 1
Const REG_EXPAND   = 2
Const REG_BINARY   = 3
Const REG_DWORD    = 4
Const REG_MULTI    = 7
Const HKCR         = &H80000000
Const HKCU         = &H80000001
Const HKLM         = &H80000002
Const HKU          = &H80000003
Const HKCC         = &H80000005

Dim g_colNamedArgs   'Collection - Named arguments
Dim g_colUnNamedArgs 'Collection - UnNamed arguments
Dim g_blnTrace       'Boolean - switches trace screen output
Dim g_blnDebug       'Boolean - switches debug screen output
Dim g_blnLog         'Boolean - switches debug file output
Dim g_objLog         'File object - debug log

ForceScriptHost("CScript") 'Force use of CScript or WScript

If WScript.Version < MinWshVer Then Syntax

GetArguments g_colNamedArgs, g_colUnNamedArgs
If g_colNamedArgs.Exists("?") Then Syntax
If g_colNamedArgs.Exists("trace") Then g_blnTrace = True
If g_colNamedArgs.Exists("debug") Then g_blnDebug = True

'Set up script log if requested
If g_colNamedArgs.Exists("log") Then
	g_blnLog = True
	Set g_objLog = New Logger
	If g_colNamedArgs.Item("log") = "" Then
		'Set True to add time----------------+
		'Set True to add date---------+      |
		g_objLog.FileName = LogName(False, False)
	Else
		g_objLog.FileName = g_colNamedArgs.Item("log")
	End If
	
	With g_objLog
		.LogType = "text"
		.Overwrite = True
		.Open
	End With
End If
'#endregion

Trace 2, "--> Script starting"

	Main

Trace 2, "--> Script finished"

'------ Subroutines ------
Sub Main
	'#region <Dimension Variables>
	Dim objShell
	Dim objFSO
	Dim colEnv
	Dim objWMI
	Dim objFolder
	Dim pthLogFiles
	Dim intCompressAge
	Dim intDeleteAge
	'#endregion
	
	Set objShell = CreateObject("Wscript.Shell")
	Set objFSO   = CreateObject("Scripting.FileSystemObject")
	Set colEnv   = CreateObject("Wscript.Shell").Environment("Process")
	Set objWMI   = GetObject("winmgmts:\\.\root\cimv2")
	
	
	intCompressAge = 60
	intDeleteAge   = 3655
	pthLogFiles    = "D:\LogFiles"
	
	
	'#region <Check arguments are valid>
	Trace 1, "Checking supplied parameters"
	Trace 2, "Checking LogFolder parameter"
	If g_colNamedArgs.Exists("Folder") Then
		pthLogFiles = g_colNamedArgs.Item("Folder")
		Trace 2, "Folder root = " & pthLogFiles
	Else
		TrWarn 2, "/Folder not specified.  Defaulting to D:\LogFiles."
	End If
	
	Trace 2, "Checking '" & pthLogFiles & "' exists."
	If Not objFSO.FolderExists(pthLogFiles) Then
		TrErr 0, "Folder '" & pthLogFiles & "' does not exist!"
		Exit Sub
	End If
	
	
	Trace 2, "Checking CompressAge parameter"
	If g_colNamedArgs.Exists("CompressAge") Then
		Trace 2, "Supplied argument = /CompressAge:" & g_colNamedArgs.Item("CompressAge")
		If IsNumeric(g_colNamedArgs.Item("CompressAge")) Then
			intCompressAge = Int(g_colNamedArgs.Item("CompressAge"))
			Trace 2, "Days before compression = " & intCompressAge
		Else
			TrErr 0, "/CompressAge must be an integer!"
			Syntax
		End If
	Else
		TrWarn 1, "/CompressAge not specified.  Defaulting to 60 days"
	End If
	
	
	Trace 2, "Checking DeleteAge parameter"
	If g_colNamedArgs.Exists("DeleteAge") Then
		Trace 2, "Supplied argument = /DeleteAge:" & g_colNamedArgs.Item("DeleteAge")
		If IsNumeric(g_colNamedArgs.Item("DeleteAge")) Then
			intDeleteAge = Int(g_colNamedArgs.Item("DeleteAge"))
			Trace 2, "Days between compression and deletion = " & intDeleteAge
		Else
			TrErr 0, "/DeleteAge must be an integer!"
			Syntax
		End If
	Else
		TrWarn 1, "/DeleteAge not specified.  Defaulting to 60 days"
	End If
	
	'#endregion
	
' 	Trace 2, "Processing all folders in " & pthLogFiles
' 	For Each objFolder In objFSO.GetFolder(pthLogFiles).SubFolders
' 		ProcessFolder objFolder, intCompressAge, intDeleteAge
' 	Next
	
	On Error Resume Next
	Err.Clear
	Set objFolder = objFSO.GetFolder(pthLogFiles)
	If Err.Number Then
		ReportError(Err)
	Else
		ProcessFolder objFolder, intCompressAge, intDeleteAge
	End If
	
End Sub

Sub ProcessFolder(ByRef objFolder, ByVal intCompressAge, ByVal intDeleteAge)
	'#region <Dimension Variables>
	Dim objFSO
	Dim objFile
	Dim strFileName
	Dim strFilePath
	Dim strFileExtension
	'#endregion
	
	Set objFSO = CreateObject("Scripting.FileSystemObject")
	Trace 1, "ProcessFolder : -------------------"
	Trace 1, "ProcessFolder : Processing folder : " & objFolder.Name
	
	'#region <Manage log files (compress and archive)>
	Trace 1, "ProcessFolder : Checking for files to compress"
	For Each objFile In objFolder.Files
		strFileName      = objFile.Name
		strFilePath      = objFile.Path
		strFileExtension = objFSO.GetExtensionName(objFile.Path)
		Trace 2, "ProcessFolder : Found File : " & strFilePath
		
		Trace 2, "ProcessFolder :   Compress Date = " _
				& FormatDateTime(DateAdd("d", intCompressAge, objFSO.GetFile(objFile.Path).DateLastModified), vbGeneralDate)
		If DateAdd("d", intCompressAge, objFSO.GetFile(objFile.Path).DateLastModified) < Now Then
			Trace 2, "ProcessFolder :   File is past compression threshold"
			
			If Not objFSO.FolderExists(objFolder.Path & "\Archive") Then
				Trace 1, "ProcessFolder :   Creating Archive subfolder"
				objFSO.CreateFolder(objFolder.Path & "\Archive")
			End If
			
			Trace 2, "ProcessFolder :   Moving file to Archive folder"
			objFSO.MoveFile strFilePath, objFolder.Path & "\Archive\" & strFileName
			
			If ZipFile(objFolder.Path & "\Archive\" & strFileName) Then
				Trace 2, "ProcessFolder :   File Compressed successfully"
			Else
				TrErr 2, "ProcessFolder :   Failed to compress file"
			End If
		Else
			Trace 2, "ProcessFolder :   File is not yet past compression threshold"
		End If
	Next
	'#endregion
	
	'#region <Manage zip archives (delete)>
	Trace 1, "ProcessFolder : Checking for files to delete"
	If objFSO.FolderExists(objFolder.Path & "\Archive") Then
		Trace 2, "ProcessFolder : Checking archived files"
		For Each objFile In objFSO.GetFolder(objFolder.Path & "\Archive").Files
			Trace 2, "ProcessFolder : Found file : " & objFile.Name
			Trace 2, "ProcessFolder :   Delete Date = " _
				& FormatDateTime(DateAdd("d", intDeleteAge, objFSO.GetFile(objFile.Path).DateLastModified), vbGeneralDate)
			If DateAdd("d", intDeleteAge, objFSO.GetFile(objFile.Path).DateLastModified) < Now Then
				Trace 2, "ProcessFolder :   File is past deletion threshold"
				objFSO.DeleteFile objFile.Path, True
				If Err.Number Then
					ReportError(Err)
					TrErr 2, "ProcessFolder :   Failed to delete file"
				End If
			Else
				Trace 2, "ProcessFolder :   File is not yet past deletion threshold"
			End If
		Next
	Else
		Trace 2, "ProcessFolder : No archive files to manage"
	End If
	'#endregion
End Sub 

Function ZipFile(ByVal pthFileToZip)
	'#region <Dimension Variables>
	Dim objFSO    'FileSystem object
	Dim objApp    'Shell.Application object
	Dim pthZip    'Path for new zip file
	Dim filZip    'Text file object from [pthZip]
	Dim objFolder 'Compressed (zip) shell folder from [filZip]
	Dim strDateTime 
	'#endregion
	
	Trace 2, "CompressFile : Zipping file '" & pthFileToZip & "'"
	Set objFSO = CreateObject("Scripting.FileSystemObject")
	
	strDateTime = Year(Now)	
	If Len(Month(Now)) = 1 Then
		strDateTime = strDateTime & "-0" & Month(Now)
	Else
		strDateTime = strDateTime & "-"  & Month(Now)
	End If
	
	pthZip = objFSO.GetParentFolderName(pthFileToZip) & "\" & strDateTime & ".zip"
	Trace 2, "CompressFile : Zip file = '" & pthZip & "'"
	
	'Create zip file if it doesn't exist
	If Not objFSO.FileExists(pthZip) Then
		Trace 2, "CompressFile : Creating Zip file"
		Set filZip = objFSO.CreateTextFile(pthZip)
		filZip.WriteLine chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18,0)
		filZip.Close
	End If
		
	Trace 2, "CompressFile : Copying file into Zip file"
	Set objApp = CreateObject("Shell.Application")
	Set objFolder = objApp.NameSpace(pthZip)
	objFolder.MoveHere pthFileToZip, 16
	
	Trace 2, "CompressFile : Waiting for compression to complete"
	WScript.Sleep (objFSO.GetFile(pthFileToZip).Size / 20000) + 1000 'Wait time based on file size
	
	ZipFile = True
End Function

Function SortableDate(ByVal blnIncludeTime)
	Dim strDateTime
	strDateTime = Year(Now)	
	If Len(Month(Now)) = 1 Then
		strDateTime = strDateTime & "-0" & Month(Now)
	Else
		strDateTime = strDateTime & "-"  & Month(Now)
	End If
	If Len(Day(Now)) = 1 Then
		strDateTime = strDateTime & "-0" & Day(Now)
	Else
		strDateTime = strDateTime & "-"  & Day(Now)
	End If
	
	If blnIncludeTime Then
		If Len(Hour(Now)) = 1 Then
			strDateTime = strDateTime & "_0" & Hour(Now)
		Else
			strDateTime = strDateTime & "_"  & Hour(Now)
		End If
		If Len(Minute(Now)) = 1 Then
			strDateTime = strDateTime & "-0" & Minute(Now)
		Else
			strDateTime = strDateTime & "-"  & Minute(Now)
		End If
		If Len(Second(Now)) = 1 Then
			strDateTime = strDateTime & "-0" & Second(Now)
		Else
			strDateTime = strDateTime & "-"  & Second(Now)
		End If
	End If
	
	SortableDate = strDateTime
End Function

'#region <Helper routines>
Class Logger
	'#region <Dimension Class variables>
	Private c_objFSO       'FileSystemObject
	Private c_strFileName  'String containing file name and path
	Private c_objLogFile   'Log file object
	Private c_blnFileOpen  'Boolean indicating that the file is open
	Private c_strType      'String indicating log type
	Private c_strError     'String containing last recorded error
	Private c_blnOverWrite 'Boolean indicating that the existing file should be overwritten
	Private c_blnTrace     'Enable class internal trace
	'#endregion
	
	Private Sub Class_Initialize()
		'Create FileSystemObject and set defaults
		Set c_objFSO = CreateObject("Scripting.FileSystemObject")
		c_strFileName  = ""
		c_strType      = "text"
		c_blnOverWrite = False
		c_blnFileOpen  = False
		c_blnTrace     = False 'Change to True if external Trace routine exists
	End Sub
	
	Private Function MakePath(ByVal strFileName, ByRef objFSO)
		Dim strFolder
		Dim strTempPath
		
		On Error Resume Next
		For Each strFolder In Split(Left(strFileName, InStrRev(strFileName, "\") - 1), "\")
			If strTempPath = "" Then
				strTempPath = strFolder
			Else
				strTempPath = strTempPath & "\" & strFolder
			End If
			If Not objFSO.FolderExists(strTempPath) Then
				cTrace "Creating folder '" & strTempPath & "'"
				objFSO.CreateFolder(strTempPath)
				If Err.Number Then
					MakePath = False
					Exit Function
				End If
			End If
		Next
		MakePath = True
	End Function

	Private Sub cTrace(ByVal strData)
		On Error Resume Next
		If c_blnTrace Then
			Trace 2, "[Logger] " & strData
			If Err.Number Then
				Err.Clear
				WScript.Echo Now & " : [Logger] " &  strData
			End If
		End If
		On Error GoTo 0
	End Sub

	Public Property Let FileName(ByVal strFileName)
		c_strFileName = strFileName
		cTrace "Log File name set to '" & strFileName & "'"
	End Property

	Public Property Get FileName
		FileName = c_strFileName
	End Property

	Public Property Let Overwrite(ByVal blnOverWrite)
		If blnOverWrite Then
			c_blnOverWrite = True
			cTrace "Overwrite ON"
		Else
			c_blnOverWrite = False
			cTrace "Overwrite OFF"
		End If
	End Property

	Public Property Get Overwrite
		If c_blnOverWrite Then
			Overwrite = True
		Else
			Overwrite = False
		End If
	End Property

	Public Property Let LogType(ByVal strType)
		Select Case LCase(strType)
			Case "text"
				c_strType = "text"
			Case "html"
				c_strType = "html"
			Case Else
				Err.Raise 101, "Logger", "LogType must be 'text' or 'html'"
		End Select
		cTrace "Log type = " & c_strType
	End Property

	Public Property Get LogType
		LogType = c_strType
	End Property

	Public Property Let TraceCode(ByVal blnTrace)
		c_blnTrace = blnTrace
	End Property
	
	Public Property Get TraceCode
		TraceCode = c_blnTrace
	End Property

	Public Property Get ErrorVal
		ErrorVal = c_strError
	End Property
	
	Public Function Close
		If c_blnFileOpen Then
			'File is open, tidy up, close file and return True
			If c_strType = "html" Then
				cTrace "Closing HTML"
				c_objLogFile.WriteLine VbCrLf & "</body>" & VbCrLf & "</html>"
			End If
			cTrace "Closing file"
			c_objLogFile.Close
			Close = True
		Else
			'File is not open, return false
			cTrace "Cannot close a file that is not open"
			Close = False
		End If
	End Function

	Public Function Open
		On Error Resume Next
		If Not c_blnFileOpen Then
			'File is not yet open
			cTrace "File not open"
			If Len(c_strFileName) > 0 Then
				'Filename is set
				If c_objFSO.FileExists(c_strFileName) Then
					'File already exists.  Overwrite if set or return False
					cTrace "File already exists"
					If c_blnOverWrite Then
						cTrace "Overwrite ON - Creating new file"
						Set c_objLogFile = c_objFSO.CreateTextFile(c_strFileName, True)
						If Err.Number Then
							cTrace "Error " & Err.Number & ", " & Err.Description
							Open = False
							c_blnFileOpen = False
							On Error GoTo 0
							Err.Raise 106, "Logger", "Cannot create file in specified folder"
						Else
							Open = True
							c_blnFileOpen = True
						End If
					Else
						If c_strType = "html" Then
							cTrace "Cannot append to a HTML file"
							Open = False
							On Error GoTo 0
							Err.Raise 105, "Logger", "You can't append to a valid HTML file without producing invalid HTML"
						Else
							cTrace "Overwrite OFF - Opening file"
							Set c_objLogFile = c_objFSO.OpenTextFile(c_strFileName, 8)
							If Err.Number Then
								cTrace "Error " & Err.Number & ", " & Err.Description
								Open = False
								c_blnFileOpen = False
								On Error GoTo 0
								Err.Raise 107, "Logger", "Cannot open specified file"
							Else
								Open = True
								c_blnFileOpen = True
							End If
						End If
					End If
				Else
					'File doesn't exist. Create folder if necessary
					cTrace "File doesn't exist - creating"
					If InStr(c_strFileName, "\") Then
						'Path specified - check it exists
						cTrace "Path specified"
						If Not c_objFSO.FolderExists(Left(c_strFileName, InStrRev(c_strFileName, "\")- 1)) Then
							'Can't find path - Create it
							cTrace "Creating path '" & Left(c_strFileName, InStrRev(c_strFileName, "\")- 1) & "'"
							If Not MakePath(c_strFileName, c_objFSO) Then
								Open = False
								Err.Raise 103, "Logger", "Cannot create path specified in filename"
							End If
						Else
							cTrace "Path already exists"
						End If
					Else
						'No path specified
						cTrace "Path not specified"
					End If
					
					'Path is now OK - Create file
					Set c_objLogFile = c_objFSO.CreateTextFile(c_strFileName, True)
					If Err.Number Then
						cTrace "Error " & Err.Number & ", " & Err.Description
						Open = False
						c_blnFileOpen = False
						On Error GoTo 0
						Err.Raise 106, "Logger", "Cannot create file in specified folder"
					Else
						Open = True
						c_blnFileOpen = True
						cTrace "File created"
					End If
				End If
			Else
				cTrace "Error: Invalid filename: '" & c_strFileName & "'"
				Open = False
				On Error GoTo 0
				Err.Raise 104, "Logger", "Invalid filename: '" & c_strFileName & "'"
			End If
			
			If c_blnFileOpen Then
				If c_strType = "html" Then
					cTrace "HTML file.  Writing HTML header"
					c_objLogFile.WriteLine "<!DOCTYPE html PUBLIC ""-//W3C//DTD XHTML 1.1//EN"" ""http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"">"
					c_objLogFile.WriteLine "<html xmlns=""http://www.w3.org/1999/xhtml"">"
					'#region <HTML Header>
					c_objLogFile.WriteLine "<head>"
					c_objLogFile.WriteLine "  <meta http-equiv=""content-type"" content=""text/html;charset=iso-8859-1"" />"
					c_objLogFile.WriteLine "  <title>" & TITLE & "</title>"
					c_objLogFile.WriteLine "  <style type=""text/css"" media=""screen""> <!--"
					c_objLogFile.WriteLine "	body,td,p  {font-size:11px; font-family:Tahoma,Arial,Helvetica;}"
					c_objLogFile.WriteLine "	hr         {width:770px; height:1px; text-align:left;}"
					c_objLogFile.WriteLine "	caption    {font-size: 11px; font-weight:bold;}"
					c_objLogFile.WriteLine "	tr.odd     {background-color:#eee;}"
					c_objLogFile.WriteLine "	tr         {background-color:#ddd;}"
					c_objLogFile.WriteLine "	td         {padding-left:5px; padding-right:2px; background-color:#DDDDDD;}"
					c_objLogFile.WriteLine "	th         {background-color:#666; color:white; font-size:11px; text-align:left; padding-left:5px; padding-right:2px;}"
					c_objLogFile.WriteLine "	.fail      {color:#9C0006; background-color:#FFC7CE; font-weight:bold;}"
					c_objLogFile.WriteLine "	.success   {color:#006100; background-color:#C8EFCE; font-weight:normal;}"
					c_objLogFile.WriteLine "	.note      {font-size: 11px; font-weight:normal; color:blue;}"
					c_objLogFile.WriteLine "	.highlight {color:blue; font-weight:bold;}"
					c_objLogFile.WriteLine "	.fixed     {font-family:'Lucida Console','Courier New',Courier;}"
					c_objLogFile.WriteLine "	.title     {font-size:15px; font-weight:bold; text-align:center;}"
					c_objLogFile.WriteLine "	.subtitle  {font-size:11px; font-weight:bold; text-align:center;}"
					c_objLogFile.WriteLine "	.mouse     {font-size:9px;}"
					c_objLogFile.WriteLine "	.heading   {font-size:12px; font-weight:bold;} -->"
					c_objLogFile.WriteLine "  </style>"
					c_objLogFile.WriteLine "  <style type=""text/css"" media=""print""> <!--"
					c_objLogFile.WriteLine "	body,td,p  {font-size:10pt; font-family:""Arial Narrow"",Helvetica;}"
					c_objLogFile.WriteLine "	hr         {width:770px; height:2pt; text-align:left;}"
					c_objLogFile.WriteLine "	caption    {font-size: 10pt; font-weight:bold;}"
					c_objLogFile.WriteLine "	td         {padding-left:2pt; border-bottom: 1px dashed silver;}"
					c_objLogFile.WriteLine "	th         {font-size:10pt; text-align:left; border-bottom: 1px solid black;}"
					c_objLogFile.WriteLine "	.fail      {color:red; font-size:10pt;}"
					c_objLogFile.WriteLine "	.success   {color:green; font-size:10pt;}"
					c_objLogFile.WriteLine "	.fixed     {font-family:'Lucida Console','Courier New',Courier;}"
					c_objLogFile.WriteLine "	.highlight {color:blue; font-weight:bold;}"
					c_objLogFile.WriteLine "	.note      {font-size: 8pt; font-weight:normal; color:blue;}"
					c_objLogFile.WriteLine "	.title     {font-size:14pt; font-weight:bold; text-align:center;}"
					c_objLogFile.WriteLine "	.mouse     {font-size:8pt;}"
					c_objLogFile.WriteLine "	.heading   {font-size:10pt; font-weight:bold;} -->"
					c_objLogFile.WriteLine "  </style>"
					c_objLogFile.WriteLine "</head>"
					'#endregion
					c_objLogFile.WriteLine "<body>"
				End If
			End If
		Else
			cTrace "Error: File already opened"
			Open = False
			On Error GoTo 0
			Err.Raise 102, "Logger Class", "Log file is already open"
		End If
	End Function
		
	Public Sub ClearErr
		c_strError = ""
	End Sub
	
	Public Sub Write(ByVal strData)
		c_objLogFile.Write strData
	End Sub

	Public Sub WriteLine(ByVal strData)
		Select Case c_strType
			Case "text"
				c_objLogFile.WriteLine strData
			Case "html"
				c_objLogFile.WriteLine strData & "<br />"
			Case Else
				c_strError = "Unknown log type"
		End Select
	End Sub

	Public Sub WriteHtml(ByVal strData, ByVal strTag, ByVal strClass)
		If strClass = "" Then
			If strTag = "" Then
				c_objLogFile.Write strData
			Else
				c_objLogFile.WriteLine "<" & strTag & ">" & strData & "</" & strTag & ">"
			End If
		Else
			If strTag = "" Then
				c_objLogFile.WriteLine "<span class='" & strClass & "'>" & strData & "</span>"
			Else
				c_objLogFile.WriteLine "<" & strTag & " class='" & strClass & "'>" & strData & "</" & strTag & ">"
			End If
		End If
	End Sub

End Class

Sub GetArguments(ByRef NamedArguments, ByRef UnNamedArguments)
	'#region <Dimension Variables>
	Dim strArg   'Current argument
	Dim arrArgs  'Array of arguments
	Dim intSplit 'Position of name/value separator [:]
	'#endregion
	
	If WScript.Version >= 5.6 Then
		Set NamedArguments   = Wscript.Arguments.Named
		Set UnNamedArguments = Wscript.Arguments.Unnamed
	Else
		'Named and unnamed arguments collections don't exist in this version of WSH, so create them
		On Error Resume Next
		Set NamedArguments   = CreateObject("Scripting.Dictionary")
		Set UnNamedArguments = CreateObject("Scripting.Dictionary")
		NamedArguments.CompareMode   = 1 'Text compare mode (not case sensitive)
		UnNamedArguments.CompareMode = 1
		
		'Loop through arguments and find the named ones
		For Each strArg In WScript.Arguments
			'See if the argument is named (starts with a '/')
			If Left(strArg, 1) = "/" Then
				'Argument is named - split it if it has an associated value
				intSplit = Instr(strArg, ":")
				If intSplit > 0 Then
					'Add the argument and it's value to the dictionary
					NamedArguments.Add Mid(strArg, 2, intSplit - 2), Mid(strArg, intSplit + 1)
				Else
					'Argument doesn't have a value, just add it with an empty string
					NamedArguments.Add Mid(strArg, 2), ""
				End If
			Else
				'Argument is unnamed and doesn't have a value, just add it with an empty string
				UnNamedArguments.Add strArg, ""
			End If
		Next
		On Error GoTo 0
	End If
End Sub

Function LogName(ByVal blnAddDate, ByVal blnAddTime)
	'#region <Dimension Variables>
	Dim pthLogName 'Constructed path of log file
	Dim objFSO     'File System Object
	Dim colEnv     'Collection of Environment Variables
	'#endregion
	
	If Left(WScript.ScriptFullName, 2) = "\\" Then
		'Script is on a UNC path - store log in control folder if possible
		Set objFSO = CreateObject("Scripting.FileSystemObject")
		Set colEnv = CreateObject("Wscript.Shell").Environment("Process")
		
		If objFSO.FolderExists(colEnv("SYSTEMDRIVE") & "\Control") Then
			pthLogName = colEnv("SYSTEMDRIVE") & "\Control\" & Left(WScript.ScriptName, InStrRev(WScript.ScriptName, ".") - 1)
		ElseIf objFSO.FolderExists(colEnv("SYSTEMDRIVE") & "\Xfer\Control") Then
			pthLogName = colEnv("SYSTEMDRIVE") & "\Xfer\Control\" & Left(WScript.ScriptName, InStrRev(WScript.ScriptName, ".") - 1)
		Else
			pthLogName = colEnv("SYSTEMDRIVE") & "\" & Left(WScript.ScriptName, InStrRev(WScript.ScriptName, ".") - 1)
		End If
		Set objFSO = Nothing
		Set colEnv = Nothing
	Else
		'Store log with script
		pthLogName = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, ".") - 1)
	End If
	
	If blnAddDate Then
		'Add the date (reversed - _YYYY-MM-DD) to the file name
		pthLogName = pthLogName & "_" & Year(Now)	
		If Len(Month(Now)) = 1 Then
			pthLogName = pthLogName & "-0" & Month(Now)
		Else
			pthLogName = pthLogName & "-" & Month(Now)
		End If
		If Len(Day(Now)) = 1 Then
			pthLogName = pthLogName & "-0" & Day(Now)
		Else
			pthLogName = pthLogName & "-" & Day(Now)
		End If
	End If
	
	If blnAddTime Then
		'Add the Time (_HH-MM)to the file name
		pthLogName = pthLogName & "_"
		If Len(Hour(Now)) = 1 Then
			pthLogName = pthLogName & "0" & Hour(Now)
		Else
			pthLogName = pthLogName & Hour(Now)
		End If
		If Len(Minute(Now)) = 1 Then
			pthLogName = pthLogName & "-0" & Minute(Now)
		Else
			pthLogName = pthLogName & "-" & Minute(Now)
		End If
	End If
	
	'Finish off with the extension and return the result
	LogName = pthLogName & ".log"
End Function

Sub ForceScriptHost(ByVal ScriptHost)
	'#region <Dimension Variables>
	Dim strGoodHost  'The host we do want to run in
	Dim strBadHost   'The host we don't want to run in
	Dim strCommand   'Command line to run, if necessary
	Dim strArgument  'Single argument supplied to this script
	Dim strArguments 'List of all arguments supplied to this script
	'#endregion
	
	Select Case Lcase(ScriptHost)
		Case "cscript.exe", "cscript", "c"
			strGoodHost = "cscript.exe"
			strBadHost  = "wscript.exe"
		Case "wscript.exe", "wscript", "w"
			strGoodHost = "wscript.exe"
			strBadHost  = "cscript.exe"
		Case Else
			Err.Raise 999, "Sub ForceScriptHost", ScriptHost & " is not a valid WSH host!"
	End Select
	
	If Instr(Lcase(Wscript.FullName), strBadHost) Then
		If Wscript.Arguments.Count > 0 Then
			For Each strArgument in Wscript.Arguments
				strArguments = strArguments & strArgument & " "
			Next
		End If
		strCommand = "%COMSPEC% /K %SYSTEMROOT%\System32\" & strGoodHost & " """ & Wscript.ScriptFullName & """ " & strArguments
		CreateObject("Wscript.Shell").Run(strCommand)
		Wscript.Quit
	End If
End Sub

Sub Trace(ByVal intLevel, ByVal strTrace)
	'intLevel 0 = Displayed always
	'intLevel 1 = Displayed with /trace or /debug
	'intLevel 2 = Displayed with /debug
	Dim strDateTime

	Select Case intLevel
		Case 2
			'Log to StdOut when /debug argument is set
			If g_blnDebug Then
				WScript.Echo Now & " : " & strTrace
			End If
		Case 1
			'Log to StdOut when /trace or /debug arguments are set
			If (g_blnTrace Or g_blnDebug) Then
				WScript.Echo Now & " : " & strTrace
			End If
		Case 0
			'Always log to StdOut
			If (g_blnTrace Or g_blnDebug) Then
				WScript.Echo Now & " : " & strTrace
			Else
				WScript.Echo strTrace
			End If
		Case Else
			Err.Raise 999, "subTrace", "Unknown Trace level : " & intLevel & VbCrLf & strTrace
	End Select
	
	'Log to file if /log argument is set
	If g_blnLog Then
		'#region <Generate the reversed date & time - 'YYYY/MM/DD HH:MM:SS'>
		strDateTime = Year(Now)	
		If Len(Month(Now)) = 1 Then
			strDateTime = strDateTime & "/0" & Month(Now)
		Else
			strDateTime = strDateTime & "/"  & Month(Now)
		End If
		If Len(Day(Now)) = 1 Then
			strDateTime = strDateTime & "/0" & Day(Now)
		Else
			strDateTime = strDateTime & "/"  & Day(Now)
		End If
		If Len(Hour(Now)) = 1 Then
			strDateTime = strDateTime & " 0" & Hour(Now)
		Else
			strDateTime = strDateTime & " "  & Hour(Now)
		End If
		If Len(Minute(Now)) = 1 Then
			strDateTime = strDateTime & ":0" & Minute(Now)
		Else
			strDateTime = strDateTime & ":"  & Minute(Now)
		End If
		If Len(Second(Now)) = 1 Then
			strDateTime = strDateTime & ":0" & Second(Now)
		Else
			strDateTime = strDateTime & ":"  & Second(Now)
		End If
		'#endregion
		g_objLog.WriteLine strDateTime & " : " & strTrace
	End If
End Sub

Sub TrWarn(ByVal intLevel, ByVal strTrace)
	Trace intLevel, "WARNING: " & strTrace
End Sub

Sub TrErr(ByVal intLevel, ByVal strTrace)
	Trace intLevel, "ERROR: " & strTrace
End Sub

Sub ReportError(Err)
'#region <Dimension Variables>
	Dim wmiLastError  'WMI Last error object
	Dim wmiProperties 'Collection of WMI property objects
	Dim wmiProperty   'Single object from [wmiProperties]
'#endregion
	
	'Report standard error details
	TrErr 0, "0x" & Hex(Err.Number)
	If Len(Err.Description) Then TrErr 0, Err.Description
	
	'Report WMI error details
	Set wmiLastError = CreateObject("WBemscripting.SWBemlasterror")
	Set wmiProperties = wmiLastError.Properties_
	For Each wmiProperty In wmiProperties 
		Select Case wmiProperty.Name 
			Case "StatusCode"
				TrErr 0, wmiProperty.Name & " = 0x" & Hex (wmiProperty.Value)
			Case "Description"
				TrErr 0, wmiProperty.Value
			Case Else
				TrErr 0, wmiProperty.Name & " = " & wmiProperty.Value
		End Select
	Next
	Err.Clear
	Set wmiProperties = Nothing
End Sub

Sub Syntax
'Show correct usage of this utility
	Wscript.Echo VbCrLf & " " & TITLE & " (version " & VERSION & ")" _
		& VbCrLf & " " & String(Len(TITLE & " (version " & VERSION & ")"), "=") _
		& VbCrLf _
		& VbCrLf & " Description" _
		& VbCrLf & "   This script will perform standard log rotation tasks for all within the" _
		& VbCrLf & "   sub-folders of a given folder.  All files over a given age in each " _
		& VbCrLf & "   subfolder will be zipped and moved to an 'Archive' folder created within" _
		& VbCrLf & "   each folder.  All files within each 'Archive' folder over another given" _
		& VbCrLf & "   age will be deleted." _
		& VbCrLf _
		& VbCrLf & " Syntax" _
		& VbCrLf & "   Cscript " & Wscript.ScriptName _
		& VbCrLf & "               [/Folder: /CompressAge: /DeleteAge: /log[:] /debug /?]" _
		& VbCrLf _
		& VbCrLf & " Required Arguments" _
		& VbCrLf & "   [none]" _
		& VbCrLf _
		& VbCrLf & " Optional arguments" _
		& VbCrLf & "   /Folder: [String] Default = D:\LogFiles" _
		& VbCrLf & "       The full path to the root folder containing the files to archive" _
		& VbCrLf & "   /CompressAge: [Integer] Default = 60" _
		& VbCrLf & "       The age (in days) before a file will be compressed and archived" _
		& VbCrLf & "   /DeleteAge:   [Integer] Default = 3655" _
		& VbCrLf & "       The age (in days) before a compressed file will be deleted" _
		& VbCrLf & "   /?            Show this guide" _
		& VbCrLf & "   /trace        Show script debugging information" _
		& VbCrLf & "   /debug        Show detailed script debugging information" _
		& VbCrLf & "   /log          Log debugging info to default file" _
		& VbCrLf & "   /log:#        Log debugging info to specified file" _
		& VbCrLf _
		& VbCrLf & " Requirements" _
		& VbCrLf & "   -> Minimum Windows Script Host version = " & MinWshVer _
		& VbCrLf & "      Current Windows Script Host version = " & WScript.Version _
		& VbCrLf
	Wscript.Quit(-1)
End Sub
'#endregion
Open in new window
ASKER CERTIFIED SOLUTION
sherryfitzgroup
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
sherryfitzgroup
ASKER
Script works