Need to exclude certain folders in search VBScript

**randalldale** · May 22, 2008

Hi Guys,

I have to use a script to migrate some file types and wanted you to look at my code to see if you knew how I can exclude certain folders to be searched as I'm already copying certain folders and don't need double copies?

Look below at my code and see if you know how to exclude c:\Documents and Setting\*.* for instance. I have tried using an if statement in the GetSubFolders strFolderName area but the loop exits before finishing.

Also I'm a bit of a novice so go easy on me if it is obvious.

Thanks,

Randy

strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
strFolderName = "c:\"
Set colSubfolders = objWMIService.ExecQuery _
    ("Associators of {Win32_Directory.Name='" & strFolderName & "'} " _
        & "Where AssocClass = Win32_Subdirectory " _
            & "ResultRole = PartComponent")
arrFolderPath = Split(strFolderName, "\")
strNewPath = ""
For i = 1 to Ubound(arrFolderPath)
    strNewPath = strNewPath & "\\" & arrFolderPath(i)
Next
strPath = strNewPath & "\\"
Set colFiles = objWMIService.ExecQuery _
    ("Select * from CIM_DataFile where Path = '" & strPath & "'")
For Each objFolder in colSubfolders
    GetSubFolders strFolderName
Next
Sub GetSubFolders(strFolderName)
    Set colSubfolders2 = objWMIService.ExecQuery _
        ("Associators of {Win32_Directory.Name='" & strFolderName & "'} " _
            & "Where AssocClass = Win32_Subdirectory " _
                & "ResultRole = PartComponent")
    For Each objFolder2 in colSubfolders2
        strFolderName = objFolder2.Name
        arrFolderPath = Split(strFolderName, "\")
        strNewPath = ""
        For i = 1 to Ubound(arrFolderPath)
            strNewPath = strNewPath & "\\" & arrFolderPath(i)
        Next
        strPath = strNewPath & "\\"
         Set colFiles = objWMIService.ExecQuery _
            ("Select * from CIM_DataFile where Path = '" & strPath & "'")
        For Each objFile in colFiles
            If objFile.Extension = "mpeg" Then
        		strCopy = "G:\MGData\Video\" & objFile.FileName & "." & objFile.Extension
        		objFile.Copy(strCopy)
 	    	End If
            If objFile.Extension = "mpg" Then
        		strCopy = "G:\MGData\Video\" & objFile.FileName & "." & objFile.Extension
        		objFile.Copy(strCopy)
 	   		End If
            If objFile.Extension = "avi" Then
        		strCopy = "G:\MGData\Video\" & objFile.FileName & "." & objFile.Extension
        		objFile.Copy(strCopy)
 	    	End If
            If objFile.Extension = "jpg" Then
        		strCopy = "G:\MGData\Pictures\" & objFile.FileName & "." & objFile.Extension
        		objFile.Copy(strCopy)
		    End If
            If objFile.Extension = "bmp" Then
        		strCopy = "G:\MGData\Pictures\" & objFile.FileName & "." & objFile.Extension
        		objFile.Copy(strCopy)
		    End If
            If objFile.Extension = "doc" Then
        		'strCopy = "G:\MGData\Documents\" & objFile.FileName & "." & objFile.Extension
        		'objFile.Copy(strCopy)
		    End If
            If objFile.Extension = "ppt" Then
        		strCopy = "G:\MGData\Documents\" & objFile.FileName & "." & objFile.Extension
        		objFile.Copy(strCopy)
		    End If
            If objFile.Extension = "txt" Then
        		strCopy = "G:\MGData\Documents\" & objFile.FileName & "." & objFile.Extension
        		objFile.Copy(strCopy)
		    End If
            If objFile.Extension = "pdf" Then
        		strCopy = "G:\MGData\Documents\" & objFile.FileName & "." & objFile.Extension
        		objFile.Copy(strCopy)
		    End If
        Next
        GetSubFolders strFolderName
    Next
End Sub

**gunsmokingman** · May 23, 2008

Here is a script that will list all folders except doc and setting folder. It was easier for me to write

up a new script for you.

'-> Script By Gunsmokingman
Option Explicit
On Error Resume Next 
 Const OverWrite = True
 Dim Fso :Set Fso = CreateObject("Scripting.FileSystemObject")
 Dim ColF, ColFiles, CopyTo, StrF, SubF, Subfolder
'/-> Array To Store All Folder Paths
 Dim Dir : Dir = Array( _
			 "G:\MGData\",_
			 "Video\",_
			 "Pictures\",_
			 "Documents\")
'/-> Start Folder 
   ShowSubfolders Fso.GetFolder("C:\")
	Function ShowSubFolders(Folder)
	 For Each Subfolder in Folder.SubFolders
'/-> Filter Out The Doc And Setting Folders
	 If InStr(LCase(Subfolder),LCase("Documents and Settings")) Then 
	 Else
	  ListFiles()
	  ShowSubFolders Subfolder
	 End If 
	 Next
	End Function
'/-> List The Files In The Sub Folder
   Function ListFiles()
	Set ColFiles = Subfolder.Files
	For Each StrF in ColFiles
'/-> Filter The File Types
	 If InStr(LCase(StrF.path),LCase(".avi")) Then 
	  CopyTo = Dir(0) & Dir(1)
	  Copy_To()
	 ElseIf InStr(LCase(StrF.path),LCase(".bmp")) Then 
	  CopyTo = Dir(0) & Dir(2)
	  Copy_To()
	 ElseIf InStr(LCase(StrF.path),LCase(".doc")) Then 
	  CopyTo = Dir(0) & Dir(3)
	  Copy_To()
	 ElseIf InStr(LCase(StrF.path),LCase(".jpg")) Then 
	  CopyTo = Dir(0) & Dir(2)
	  Copy_To()
	 ElseIf InStr(LCase(StrF.path),LCase(".mpeg")) Then 
	  CopyTo = Dir(0) & Dir(1)
	  Copy_To()
	 ElseIf InStr(LCase(StrF.path),LCase(".mpg")) Then 
	  CopyTo = Dir(0) & Dir(1)
	  Copy_To()
	 ElseIf InStr(LCase(StrF.path),LCase(".pdf")) Then 
	  CopyTo = Dir(0) & Dir(3)
	  Copy_To()
	 ElseIf InStr(LCase(StrF.path),LCase(".ppt")) Then 
	  CopyTo = Dir(0) & Dir(3)
	  Copy_To()
	 ElseIf InStr(LCase(StrF.path),LCase(".txt")) Then 
	  CopyTo = Dir(0) & Dir(3)
	  Copy_To()
	 End If 
	Next 
   End Function
'/-> Check For Folder Exists Then Copy 
   Function Copy_To()
	If Not Fso.FolderExists(CopyTo) Then Fso.CreateFolder(CopyTo)
	Fso.CopyFile StrF.Path , CopyTo & StrF.Name, OverWrite 
'/-> Uncomment If You Are Using Cmd Promt And Want A Output Of The Copy
	 ' WScript.Echo  StrF.Path & vbCrLf & CopyTo & StrF.Name & vbCrLf
   End Function

**randalldale** · May 28, 2008

Thanks,

I will take a look but to use your code I will have to redesign my whole HTA file.

More to come I'm sure.

**randalldale** · May 28, 2008

GunSmokingMan thanks the coding but I'm enough of a NOOB that I can't figure out how to integrate it into my system.

I've gotten my code to work .... well sort of It seems to only want to run 2 subdirectories and at some point it does get an error "line 120, char 6, error, could not complete the operation due to error 80041017, code 0"

Line 120 is

Set colSubfolders2 = objWMIService.ExecQuery("Associators of {Win32_Directory.Name='" & strFolderName & "'} " & "Where AssocClass = Win32_Subdirectory " & "ResultRole = PartComponent")

it appears to be one of the directories but haven't figured out which yet.

I added some err capture but haven't been having much success with it.

If you can figrue out how to integrate your coding so that it is using the array I'm building because it is a dyanmic array that would be great!

I've attached my code.

	<script LANGUAGE="vbscript">
	On Error Resume Next
	Dim SYSID, ColDrv, Fso, objWShell, intSize
	Dim strPath, strDate
	Dim aryDirectories()
	Dim aryDirectories2()
	Function Window_OnLoad()
		'finds the next available drive letter
		Dim Drv, StrDrv
		intSize = 0
		Set objDictionary = CreateObject("Scripting.Dictionary")
		strComputer = "."
		Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
		Set colDisks = objWMIService.ExecQuery("Select * from Win32_LogicalDisk")
		For Each objDisk in colDisks
			objDictionary.Add objDisk.DeviceID, objDisk.DeviceID
		Next
		For i = 67 to 90
			strDrive = Chr(i) & ":"
			If objDictionary.Exists(strDrive) Then
			Else
				ColDrv = strDrive
				Exit For
			End If
		Next
		IntSize = intSize + 1
		ReDim Preserve aryDirectories(intSize)
		ReDim Preserve aryDirectories2(intSize)
		aryDirectories(intSize) = UCase ("C:\Documents and Settings")
		aryDirectories2(intSize) = UCase ("Documents and Settings")
		intSize = intSize + 1
		ReDim Preserve aryDirectories(intSize)
		ReDim Preserve aryDirectories2(intSize)
		aryDirectories(intSize) = UCase ("C:\DATA")
		aryDirectories2(intSize) = UCase ("DATA")
		IntSize = intSize + 1
		ReDim Preserve aryDirectories(intSize)
		ReDim Preserve aryDirectories2(intSize)
		aryDirectories(intSize) = UCase ("C:\MyBackup")
		aryDirectories2(intSize) = UCase ("MyBackup")
		MsgBox "If the USB Hard drive was already plugged in you need to select exit and start over otherwise you may now plug in your USB Hard Drive and press 'OK'"
	End Function
	Sub GetSubFolders(strFolderName)
		On Error Resume Next
		Dim strErrFile, objErrFile, strLogFile, objLogFile
		strErrFile = "c:\ErrLog.txt"
		strLogFile = "c:\CopyLog.txt"
		Set objFSO = CreateObject("Scripting.FileSystemObject")
		Set objErrFile = objFSO.CreateTextFile(strErrFile)
		Set objLogFile = objFSO.CreateTextFile(strLogFile)
		Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
		Set colSubfolders2 = objWMIService.ExecQuery _
			("Associators of {Win32_Directory.Name='" & strFolderName & "'} " _
				& "Where AssocClass = Win32_Subdirectory " _
					& "ResultRole = PartComponent")
		If Err.Number <> 0 Then
		objErrFile.WriteLine" " & Err.Description & " " & Err.Number & " " & Err.HelpContext
		Err.Clear
		Else
			For Each objFolder2 in colSubfolders2
				strFolderName = objFolder2.Name
				arrFolderPath = Split(strFolderName, "\")
				strNewPath = ""
				For i = 1 To Ubound(arrFolderPath)
					strNewPath = strNewPath & "\\" & arrFolderPath(i)
				Next
				strPath = strNewPath & "\\"
				Set colFiles = objWMIService.ExecQuery _
					("Select * From CIM_DataFile Where Path = '" & strPath & "' AND LastModified > '" & strDate & "'")
				For Each objFile In colFiles
					objLogFile.WriteLine" " & strPath
					MsgBox strPath
					If objFile.Extension = "doc" Then
						strCopy = ColDrv & "\MGData\" & MigrateBox.value & "\Files\" & objFile.FileName & "." & objFile.Extension
						If objFSO.FileExists(strCopy) Then
						strCopy = ColDrv & "\MGData\" & MigrateBox.value & "\Files\" & objFile.FileName & "1" & "." & objFile.Extension
						End If
						objLogFile.WriteLine" " & objFile.FileName & "." & objFile.Extension
						objFile.Copy(strCopy),0,True
					End If
					If objFile.Extension = "dot" Then
						strCopy = ColDrv & "\MGData\" & MigrateBox.value & "\Files\" & objFile.FileName & "." & objFile.Extension
						If objFSO.FileExists(strCopy) Then
						strCopy = ColDrv & "\MGData\" & MigrateBox.value & "\Files\" & objFile.FileName & "1" & "." & objFile.Extension
						End If
						objLogFile.WriteLine" " & objFile.FileName & "." & objFile.Extension
						objFile.Copy(strCopy),0,True
					End If
					If objFile.Extension = "pdf" Then
						strCopy = ColDrv & "\MGData\" & MigrateBox.value & "\Files\" & objFile.FileName & "." & objFile.Extension
						If objFSO.FileExists(strCopy) Then
						strCopy = ColDrv & "\MGData\" & MigrateBox.value & "\Files\" & objFile.FileName & "1" & "." & objFile.Extension
						End If
						objLogFile.WriteLine" " & objFile.FileName & "." & objFile.Extension
						objFile.Copy(strCopy),0,True
					End If
				Next
				GetSubFolders strFolderName
			Next
		End If
	End Sub

	Function getDirectory()
		Set objWShell = CreateObject("WScript.Shell")
		Set Fso = CreateObject("Scripting.FileSystemObject")
		strDirectory = DirectoryBox.Value
		DirectoryBox.value = Mid(DirectoryBox.value,InStr(DirectoryBox.value,"\")+1)
		strBldDir = DirectoryBox.value
		'MsgBox strBldDir
		DirectoryBox.value = ""
		intSize = intSize + 1
		ReDim Preserve aryDirectories(intSize)
		ReDim Preserve aryDirectories2(intSize)
			aryDirectories(intSize) = strDirectory
			aryDirectories2(intSize) = strBldDir
		'MsgBox aryDirectories2(intSize)
		'MsgBox intSize
	End Function

	Function Migrate()
 		Set objFSO = CreateObject("Scripting.FileSystemObject")
		Set objWShell = CreateObject("WScript.Shell")
		MigrateBox.value = Mid(MigrateBox.value,InStr(migrateBox.value,"\")+1)
		Set Fso = CreateObject("Scripting.FileSystemObject")
		Set Drv = Fso.Drives
	 	For Each StrDrv In Drv 
		   	If StrDrv.DriveType = 4 Then
			   	If StrDrv.IsReady = True Then 
			   		ColDrvs = StrDrv.path
			   	End If
			End If
		Next
		Trim(MigrateBox.value)
		If MigrateBox.value = "" Then
			MsgBox "You did not enter a user logon, please unplug the USB HDD before pressing 'Ok'"
			objWShell.Run ColDrvs & "\Tools\Tools.hta"
		Else
			objWShell.Run "%comspec% /c md " & ColDrv & "\MGData\" & MigrateBox.value & "\MyDocs" & chr(34),0,True
			objWShell.Run "%comspec% /c md " & ColDrv & "\MGData\" & MigrateBox.value & "\Favorites",0,True
			objWShell.Run "%comspec% /c md " & ColDrv & "\MGData\" & MigrateBox.value & "\Desktop",0,True
			objWShell.Run "%comspec% /c md " & ColDrv & "\MGData\" & MigrateBox.value & "\Outlook" & chr(34),0,True
			objWShell.Run "%comspec% /c md " & ColDrv & "\MGData\" & MigrateBox.value & "\Signatures" & chr(34),0,True
			objWShell.Run "%comspec% /c md " & ColDrv & "\MGData\" & MigrateBox.value & "\Local\Outlook" & chr(34),0,True
			objWShell.Run "%comspec% /c md " & ColDrv & "\MGData\" & MigrateBox.value & "\Files" & chr(34),0,True
			If Fso.FolderExists(ColDrv &"\MGData")= False Then
				MsgBox "USB HDD not found please unplug USB HDD and follow directions after restarting migration utility."
				If Fso.FileExists(ColDrvs & "\Tools\Tools.hta") Then 
					objWShell.Run ColDrvs & "\Tools\Tools.hta"
					self.close  
				End If
			End If
			objWShell.Run "%comspec% /c xcopy " & chr(34) & "c:\Documents and Settings\" & MigrateBox.value & "\My Documents\*.*" & chr(34) & " "& Chr(34) & ColDrv & "\MGData\" & MigrateBox.value & "\MyDocs\" & chr(34) & " /E /H /O /G /I /Y",1,True
			objWShell.Run "%comspec% /c xcopy " & chr(34) & "c:\Documents and Settings\" & MigrateBox.value & "\Favorites\*.*" & chr(34) & " "& Chr(34) & ColDrv & "\MGData\" & MigrateBox.value & "\Favorites\" & chr(34) & " /E /H /O /G /I /Y",1,True
			objWShell.Run "%comspec% /c xcopy " & chr(34) & "c:\Documents and Settings\" & MigrateBox.value & "\Desktop\*.*" & chr(34) & " "& Chr(34) & ColDrv & "\MGData\" & MigrateBox.value & "\Desktop\" & chr(34) & " /E /H /O /G /I /Y",1,True
			objWShell.Run "%comspec% /c xcopy " & chr(34) & "c:\Documents and Settings\" & MigrateBox.value & "\Application Data\Microsoft\Outlook\*.*" & chr(34) & " "& Chr(34) & ColDrv & "\MGData\" & MigrateBox.value & "\Outlook\" & chr(34) & " /E /H /O /G /I /Y",1,True
			objWShell.Run "%comspec% /c xcopy " & chr(34) & "c:\Documents and Settings\" & MigrateBox.value & "\Application Data\Microsoft\Signatures\*.*" & chr(34) & " "& Chr(34) & ColDrv & "\MGData\" & MigrateBox.value & "\Signatures\" & chr(34) & " /E /H /O /G /I /Y",1,True
			objWShell.Run "%comspec% /c xcopy " & chr(34) & "c:\Documents and Settings\" & MigrateBox.value & "\Local Settings\Application Data\Microsoft\Outlook\*.*" & chr(34) & " "& Chr(34) & ColDrv & "\MGData\" & MigrateBox.value & "\Local\Outlook\" & chr(34) & " /E /H /O /G /I /Y",1,True
			For i = 2 To intSize
				'MsgBox "xcopy " & aryDirectories(i) & "\*.*"
				objWShell.Run "%comspec% /c md " & ColDrv & "\MGData\" & MigrateBox.value & "\" & aryDirectories2(i)
				objWShell.Run "%comspec% /c xcopy "& Chr(34) & aryDirectories(i) & "\*.*" & Chr(34) & " " & Chr(34) & ColDrv & "\MGData\" & MigrateBox.value & "\" & aryDirectories2(i) &"\" & Chr(34) & " /E /H /O /G /I /Y",1,True
			Next
			CollectFiles
			If Fso.FolderExists(ColDrv &"\MGData")= True Then
				If Fso.FileExists(ColDrvs & "\Tools\done.hta") Then 
					objWShell.Run ColDrvs & "\Tools\done.hta"
				End If
			End If
			self.close  
		End If
	End Function
	Function CollectFiles()
		Set objFSO = CreateObject("Scripting.FileSystemObject")
		strMonth = Month(Date)
		If Len(strMonth) = 1 Then
			strMonth = "0" & strMonth
		End If
		strDay = Day(Date)
		If Len(strDay) = 1 Then
			strDay = "0" & strDay
		End If
		strYear = Year(Date)-2
		'strdate = strYear & strMonth & strDay & "000000.000000+000"
		strdate = strMonth & "/" & strDay & "/" & strYear
		msgbox strDate & "  " & Date
		'MsgBox aryDirectories2(intSize-1)
		'MsgBox aryDirectories2(intSize)
		'MsgBox intSize
		strFolderName = "c:"
		Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
		Set colSubfolders2 = objWMIService.ExecQuery _
			("Associators of {Win32_Directory.Name='" & strFolderName & "'} " _
				& "Where AssocClass = Win32_Subdirectory " _
					& "ResultRole = PartComponent")
		For Each objFolder2 in colSubfolders2
			Found = 0
			For i = 1 To intSize
				'MsgBox UCase(objFolder2.name) & "\" & "---" & UCase("\" & aryDirectories2(i) & "\") & "=" & InStr(UCase(objFolder2.name) & "\", UCase("\" & aryDirectories2(i) & "\")) 
				If InStr(UCase(objFolder2.name) & "\", UCase("\" & aryDirectories2(i) & "\")) <> 0 Then
					Found = 1
					Exit For
				End If
			Next
			If Found = 0 Then
				GetSubFolders objFolder2.name
			End If
		Next
	End Function

	Function Tools()
		Set Fso = CreateObject("Scripting.FileSystemObject")
		Set objWShell = CreateObject("WScript.Shell")
		Set Drv = Fso.Drives
		If Fso.FileExists(ColDrv & "\Tools\Tools.hta") Then 
			objWShell.Run ColDrv & "\Tools\Tools.hta"
		End If
		'objWShell.Run ("wpeutil reboot")
		self.close  
	end Function
</script>

Sign In

Need to exclude certain folders in search VBScript

Recommended Posts

randalldale

gunsmokingman

randalldale

randalldale

Create an account or sign in to comment

Create an account

Sign in

Recently Browsing 0 members

Activity

Browse