Scripting

'// Creates a dictionary containing details of files in and under a directory.
'// Drop a folder on this script or browse for it. 
Option Explicit

Dim blnResult
Dim intIndex
Dim strMsg
Dim objFSO
Dim objWSHShell
Dim strScriptFullName
Dim objDictionary
Dim strOut
Const strNameSeparator		= "|"

Const strBrowseForFolderTitle	= "Select a folder to process"

strScriptFullName		= WScript.ScriptFullName

Set objFSO 			= CreateObject("Scripting.FileSystemObject")
Set objWSHShell 		= CreateObject("Shell.Application")
Set objDictionary		= CreateObject("Scripting.Dictionary")

Call Main

Set objDictionary		= Nothing
Set objWSHShell 		= Nothing
Set objFSO	 		= Nothing

Sub Main
	Dim objFolder
	Dim strFolder
	Dim strDest

	'// Delete existing CSV report
	If objFSO.FileExists(FileNameLikeMine("csv")) Then objFSO.DeleteFile FileNameLikeMine("csv")

	'// Get the folder you want info on
	If WScript.Arguments.Count = 1 Then
		strFolder 	= WScript.Arguments(0)
	Else
		strFolder 	= BrowseForFolder(strBrowseForFolderTitle)
	End If
	
	If strFolder = "" Then 
		Exit Sub
	End If
	
	'// Write the header (element number & names of the elements) to the CSV report/dictionary
'	Call WriteHeader
	
	Call HandleExtension(".MFS", strFolder, "C:\IMS Health\DVW\DWNLOAD")
	Call HandleExtension(".XLS", strFolder, "C:\IMS Health\DVW\REPORTS")
	Call HandleExtension(".DVR", strFolder, "C:\IMS Health\Dataview\DATA")
	
End Sub

Sub HandleExtension(ByVal strExt, ByVal strSourceFolder, ByVal strDestinationFolder)
	Dim arrDictItems
	Dim arrDictKeys
	Dim strKey
	Dim strItem
	
	'// Don't even bother to start if the destination folder doesn't exist
	If Not objFSO.FolderExists(strDestinationFolder) Then
		strMsg		= "The destination folder '" & strDestinationFolder & "' does not exist."
		MsgBox strMsg, vbOKOnly + vbExclamation
		Exit Sub
	End If
	
	'// Because I decided to call the extension types one by one, 
	'// thus using only one key, rather than x number 
	'// (where 'x' is the number of extensions to be processed)
	'// we need to empty the dictionary
	On Error Resume Next
	objDictionary.RemoveAll
	On Error Goto 0
	
	strOut = ""
	Call RecurseExtensions(objFSO.GetFolder(strSourceFolder), strExt)
	'Call RecurseFiles(objFSO.GetFolder(strSourceFolder))
	
	If IsEmpty(objDictionary) Then
		Exit Sub
	End If
	
	'// Now that we have a dictionary, we can process the items in it
	With objDictionary
		arrDictKeys	= .Keys
		arrDictItems	= .Items
		
		For intIndex = 0 To .Count - 1
			strKey	= arrDictKeys(intIndex)
			strItem	= .Item(arrDictKeys(intIndex))

			'WScript.Echo "Key = " & strKey & " Item = "  & strItem
			'// The data looks like this:
			'// Path_to_file, Name_of_file, Size, File type
			'// 	separator (see strNameSeparator)
			'// Path_to_file, Name_of_file, Size, File type
			'//	etc
			
			'// This next call is what makes this script reasonably generic:
			'// just pass the data to a function which does what you want it to do
			
			blnResult = StartProcessing(strItem, strDestinationFolder)
		Next
	End With
End Sub

Sub RecurseExtensions(ByVal objFolderName, ByVal strExt)
	Dim objSubFolders
	Dim objSubFolder
	Dim objFolder
	Dim objFile
	Dim strDetails
	Dim intElement
	Dim strFolderName
	Dim strExtension
	
	strFolderName		= objFolderName.Path
	Set objFolder 		= objWSHShell.Namespace(strFolderName)
	If Err.Number <> 0 Then 
		Exit Sub
	End If
	
	'// Write the actual data elements for each file
	For Each objFile in objFolder.Items
		With objDictionary
			If InStr(objFile.Name, ".") Then
				strExtension	= UCase(Mid(objFile.Name, InStrRev(objFile.Name, "." ) ) )
				If UCase(strExt) = UCase(strExtension) Then
					Call Say("Processing " & objFolder.GetDetailsOf(objFile, 0))
					If strOut <> "" Then 
						strOut = strOut & strNameSeparator
					End If
					
					strOut 		= strOut & strFolderName
					
					'// We're not interested in the rest of this junk
					'For intElement = 0 to 37
					For intElement = 0 To 2
						If strOut <> "" Then 
							strOut = strOut & ","
						End If
						strOut = strOut & Replace(objFolder.GetDetailsOf(objFile, intElement), ",", "")
					Next
					
					If Not .Exists(strExtension) Then
						.Add strExtension, strOut
					Else
						.Item(strExtension) = strOut
					End If
				End If
			End If
		End With
	Next
	
	'// Check for any sub-folders and recursively process them
	Set objSubFolders = objFolderName.SubFolders
	For Each objSubFolder In objSubFolders
		If LCase(objSubFolder.Name) <> "recycled" Then
			Call RecurseExtensions(objSubFolder, strExt)
		End If
	Next
	
	Set objFile		= Nothing
	Set objFolder 		= Nothing
End Sub

Function StartProcessing(ByVal strData, ByVal strDestination)
	Dim arrData
	Dim strItem
	Dim strPath
	Dim strName
	Dim strSize
	Dim strType
	Dim objFile
	Dim strSourceFile
	Dim strDestinationFile
	
	arrData			= Split(strData, strNameSeparator)
	
	For intIndex = 0 To UBound(arrData)
		strItem		= arrData(intIndex)
		WScript.Echo strItem
		
		'// Split the data into an array
		strPath		= Split(strItem, ",")(0)
		strName		= Split(strItem, ",")(1)
		strSize		= Split(strItem, ",")(2)
		strType		= Split(strItem, ",")(3)

		strSourceFile		= strPath & "\" & strName
		strDestinationFile	= strDestination & "\" & strName
		
		With objFSO
			Set objFile 	= .GetFile(strSourceFile)
			objFile.Copy(strDestinationFile)
			
			If Not .FileExists(strDestinationFile) Then
				strMsg		= "Failed to copy '" & strSourceFile & "' to '" & strDestinationFile
				MsgBox strMsg, vbOKOnly + vbExclamation
			End If
			Set objFile 	= Nothing
		End With
	Next

End Function

Sub RecurseFiles(ByVal objFolderName)
	Dim objSubFolders
	Dim objSubFolder
	Dim objFolder
	Dim objFile
	Dim strOut
	Dim intElement
	Dim strFolderName
	
	strFolderName	= objFolderName.Path
	Set objFolder 	= objWSHShell.Namespace(strFolderName)
	If Err.Number <> 0 Then 
		Exit Sub
	End If
	
	'// Write the actual data elements for each file
	For Each objFile in objFolder.Items
		Call Say("Processing " & objFolder.GetDetailsOf(objFile, 0))
		If strOut <> "" Then 
			strOut 	= strOut & vbCrLf
		End If
		
		strOut 		= strOut & strFolderName
		
		'// We're not interested in the rest of this junk
		'For intElement = 0 to 37
		For intElement = 0 To 2
			If strOut <> "" Then 
				strOut = strOut & ","
			End If
			strOut = strOut & Replace(objFolder.GetDetailsOf(objFile, intElement), ",", "")
		Next
		
		Call AddLineToDictionary(strOut)
		strOut = ""
	Next
	
	'// Check for any sub-folders and recursively process them
	Set objSubFolders = objFolderName.SubFolders
	For each objSubFolder in objSubFolders
		If LCase(objSubFolder.Name) <> "recycled" Then
			Call RecurseFiles(objSubFolder)
		End If
	Next
End Sub

Function BrowseForFolder(strPrompt)
	'// Uses the "Shell.Application" (only present in Win98 and newer)
	'// to bring up a file/folder selection window. Falls back to an
	'// ugly input box under Win95.
	
	'Shell32.Shell SpecialFolder constants
	Const ssfPERSONAL 		= 5 		'// My Documents
	Const ssfDRIVES 		= 17 		'// My Computer
	Const ssfWINDOWS 		= 36		'// Windows
	Const SFVVO_SHOWALLOBJECTS 	= 1
	Const SFVVO_SHOWEXTENSIONS 	= 2 

	Const BIF_RETURNONLYFSDIRS 	= &H0001
	Const BIF_EDITBOX 		= &H0010
	Const BIF_VALIDATE 		= &H0020
	Const BIF_NEWDIALOGSTYLE 	= &H0040

	Dim objFolder
	Dim lngView
	Dim strPath
	
	If Instr(TypeName(objWSHShell), "Shell") = 0 Then
		BrowseForFolder = InputBox(strPrompt, "Select Folder", CreateObject("Scripting.FileSystemObject").GetParentFolderName(strScriptFullName))
		Exit Function
	End If

	lngView 			= SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS
	lngView				= lngView + BIF_NEWDIALOGSTYLE + BIF_VALIDATE + BIF_EDITBOX + BIF_RETURNONLYFSDIRS

	strPath 			= ""
	
	Set objFolder 			= objWSHShell.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)
	Err.Clear
	
	On Error Resume Next
	strPath 			= objFolder.ParentFolder.ParseName(objFolder.Title).Path

	'// An error occurs if the user selects a drive instead of a folder
	'// so handle it here
	Select Case Err.Number
		Case 0
			BrowseForFolder = strPath
		Case 424
			'// User probably selected a drive. Let's see.
			'// First, have a fall-back option
			BrowseForFolder = objFolder.Title

			strPath		= objFolder.Title
			If Len(strPath) > 0 Then
				intIndex = InStr(strPath, ":") 
				If intIndex > 0 Then
					strPath	= Mid(strPath, intIndex - 1, 2) & "\"
				End If
			End If
		Case Else
	End Select
	
	'// If the user *types (or pastes) in* an incorrect path, no error is raised
	'// so handle it here
	If Len(strPath) > 0 Then
		'// Only process if something was entered/selected
		If objFSO.FolderExists(strPath) Then
			BrowseForFolder = strPath
			Exit Function
		End If
			
		strMsg		= "The folder '" & strPath & "' does not exist."
		MsgBox strMsg, vbOKOnly + vbExclamation
		BrowseForFolder = ""
	End If
	On Error Goto 0
End Function

Sub Say(strMessage)
	If LCase(Right(WScript.FullName, 12)) = "\cscript.exe" Then
		WScript.Echo strMessage
	End If
End Sub

Sub AddLineToDictionary(ByVal strText)
	'// This routine was designed around AddLineToCSVFile so the string comes in as a CSV line.
	Dim strPath
	Dim strName
	Dim strType
	Dim strSize
	
	strPath				= Split(strText, ",")(0)
	strName				= Split(strText, ",")(1)
	strSize				= Split(strText, ",")(2)
	strType				= Split(strText, ",")(3)
	
	'// Include the path to make the key unique. Without it, subsequent keys wouldn't get added
	'// because the key would already exist. I leave the path in the item because I can use
	'// Split to get at it, rather than string manipulation of the key
	objDictionary.Add strPath & "\" & strName, strSize & strNameSeparator & strType & strNameSeparator & strPath
	
End Sub

Sub AddLineToCSVFile(ByVal strText)
	Dim objTextFile
	Const intForAppending 		= 8
	Set objTextFile 		= objFSO.OpenTextFile(Left(strScriptFullName, InstrRev(strScriptFullName, ".")) & "csv", intForAppending, True)
	
	With objTextFile
		.WriteLine strText
		.Close
	End With
End Sub

Function FileNameLikeMine(ByVal strFileExtension)
	'// Returns a file name the same as the script name 
	'// except for the file extension. 
	Dim strExtension
	
	strExtension 			= strFileExtension
	If Len(strExtension) < 1 Then 
		strExtension 		= "txt"
	End If
	
	If strExtension = "." Then 
		strExtension 		= "txt"
	End If
	
	If Left(strExtension,1) = "." Then 
		strExtension 		= Mid(strExtension, 2)
	End If
	
	FileNameLikeMine 		= Left(strScriptFullName, InstrRev(strScriptFullName, ".")) & strExtension
End Function

Sub WriteHeader
	strOut = "Path"
	'// We're not interested in the rest of this junk
	'For intElement = 0 To 37
	For intElement = 0 To 2
		If strOut <> "" Then 
			strOut = strOut & ","
		End If
		
		With objFolder
			strOut = strOut & .GetDetailsOf(.Items, intElement)
		End With
	Next
End Sub