Welcome to MSFN

Register now to gain access to all of our features. Once registered and logged in, you will be able to contribute to this site by submitting your own content or replying to existing content. You'll be able to customize your profile, receive reputation points as a reward for submitting content, while also communicating with other members via your own private inbox, plus much more! This message will be removed once you have signed in.


Sign in to follow this  
Followers 0
randalldale

Need to exclude certain folders in search VBScript

4 posts in this topic

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

0

Share this post


Link to post
Share on other sites

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

0

Share this post


Link to post
Share on other sites

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.

0

Share this post


Link to post
Share on other sites

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

Share this post


Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!


Register a new account

Sign in

Already have an account? Sign in here.


Sign In Now
Sign in to follow this  
Followers 0

  • Recently Browsing   0 members

    No registered users viewing this page.