Jump to content

Welcome to MSFN Forum
Register now to gain access to all of our features. Once registered and logged in, you will be able to create topics, post replies to existing threads, give reputation to your fellow members, get your own private messenger, post status updates, manage your profile and so much more. This message will be removed once you have signed in.
Login to Account Create an Account


Photo

Need to exclude certain folders in search VBScript

- - - - -

  • Please log in to reply
3 replies to this topic

#1
randalldale

randalldale

    Member

  • Member
  • PipPip
  • 115 posts
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



How to remove advertisement from MSFN

#2
gunsmokingman

gunsmokingman

    MSFN Master

  • Super Moderator
  • 2,418 posts
  • OS:none specified
  • Country: Country Flag
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




GunSmokingMan



#3
randalldale

randalldale

    Member

  • Member
  • PipPip
  • 115 posts
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.

#4
randalldale

randalldale

    Member

  • Member
  • PipPip
  • 115 posts
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 :whistle: 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>





0 user(s) are reading this topic

0 members, 0 guests, 0 anonymous users



How to remove advertisement from MSFN