I wrote the VBS script to count all the folders under C:\ , the code as below:
set wshell = createobject("WScript.Shell")
dim fso,file,subfolder,folder
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.CreateTextFile("\\192.168.0.201\thang\Learning\test.txt")
Set folder = fso.GetFolder("C:\")
dim i,j
i = 0
j = 0
For Each subfolder In folder.SubFolders
'file.WriteLine """" & subfolder.path & """" 'print quotation marks trong VBS
'arr(i) = subfolder.path
i=i+1
Next
msgbox "i = " & i 'In my case , C folders has 19 subfolders in there
dim arr
arr = Array(i) 'declare the array which has i member
' For Each subfolder In folder.SubFolders
' 'file.WriteLine """" & subfolder.path & """" 'print quotation marks trong VBS
' arr(j) = subfolder.path
' j=j+1
' Next
' msgbox arr(0)
' msgbox arr(1)
msgbox "lbound = " & lbound(arr) 'when ran the code, it always show lbound = 0
msgbox "ubound = " & ubound(arr) 'when ran the code, it always show ubound = 0
file.close()
It show the value of i = 19 , then i define 1 array with i members , then check its lbound and ubound , however it shows lbound = 0 and ubound = 0. Can you please help correct my code ?
See: Array Function
arr = Array(i)
creates an array with a single element i.
If you need to create an array specifying a variable as size, you need to use the ReDim Statement
Redim arr(i)
Related
I would like to have a script that reads a specific folder and extracts the base file names, removes the last two characters and then uses the result to populate the text of an inputbox. The user then selects from the given options and the remainder of the script searches and replaces text in a second folder with the selected text.
Example file names in the initial target folder:
ABFA1
ABFA3
ABFA4
HVA1
HVA3
HVA4
ITALA1
ITALA3
ITALA4
Obviously, once the last 2 characters are removed, I am left with duplicates which I will need to remove.
Here is part of the script I have so far:
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFilePath = objFSO.BuildPath(objFSO.GetAbsolutePathName("."), "\dwgs\logos")
If Not objFSO.FolderExists(strFilePath) Then
wscript.echo("Folder does not exist, script exiting")
wscript.quit
End if
'
Set objFolder = objFSO.GetFolder (strFilePath)
For Each objFile In objFolder.Files
strFile = objFSO.GetBaseName(objFile.Name)
strFile = LEFT(strFile, (LEN(strFile)-2))
' wscript.echo(strFile)
Next
'delete all duplicate files names and add result to dictionary (or array?)
'create an inputbox and present a number of choices populated by the dictionary/array
user1 = InputBox("Select a Logo:"&(chr(13))&(chr(13))&(*array/dict*)), "Logo Replacement Script")
' Set arguments
strFilePath2 = objFSO.BuildPath(objFSO.GetAbsolutePathName("."), "\dwgs")
FindString = "dwgs\logos\"
ReplaceStringWith = "dwgs\logos\"&(user1)
' Find and replace function
I am able to get the base file names with the last 2 characters removed, but I dont know how to weed out the duplicates and then use the result in an inputbox? (I'm imagining text within the inputbox of a number followed by a choice and the user enters the number to signify which option to use)
My first thought was to use an array, but after some reading, it would seem a dictionary approach might be better. Unfortunately, I haven't been able to figure out how to incorporate it into the script.
Any help would be much appreciated.
Updated script incorporating input from Ekkehard:
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFilePath = objFSO.BuildPath(objFSO.GetAbsolutePathName("."), "\dwgs\logos")
'
Function ShowFilesInFolder(strFolderPath)
Set oFolder = objFSO.GetFolder(strFolderPath)
Set oFileCollection = oFolder.Files
For Each oTempFile in oFileCollection
strTemp = strTemp & oTempFile.name
strTemp = LEFT(strTemp, (LEN(strTemp)-6))
Next
ShowFilesInFolder = strTemp
End Function
x = ShowFilesInFolder(strFilePath)
'
Function mkDic(aK, aV)
Dim tmp : Set tmp = CreateObject("Scripting.Dictionary")
Dim i
For i = 0 To UBound(aK)
tmp(aK(i)) = aV(i)
Next
Set mkDic = tmp
End Function
'
Dim a : a = Split (x)
WScript.Echo Join(mkDic(a, a).Keys)
For some reason I cant get the mkDic Function to split the input from the ShowFilesInFolder Function?
Is there an easier way to go about it than what I have come up with?
The VBScript tool for uniqueness is The Dictionary. This demo (cf. here)
Option Explicit
' based on an Array 2 Dictionary function from
' !! https://stackoverflow.com/a/45554988/603855
Function mkDic(aK, aV)
Dim tmp : Set tmp = CreateObject("Scripting.Dictionary")
Dim i
For i = 0 To UBound(aK)
' tmp(aK(i)) = aV(i)
tmp(Mid(aK(i), 1, Len(aK(i)) - 2)) = aV(i)
Next
Set mkDic = tmp
End Function
Dim a : a = Split("ABFA1 ABFA3 ABFA4 HVA1 HVA3 HVA4 ITALA1 ITALA3 ITALA4")
WScript.Echo Join(a)
WScript.Echo Join(mkDic(a, a).Keys), "=>", Join(mkDic(a, a).Items)
output:
cscript 45590698.vbs
ABFA1 ABFA3 ABFA4 HVA1 HVA3 HVA4 ITALA1 ITALA3 ITALA4
ABF HV ITAL => ABFA4 HVA4 ITALA4
shows, how to de-duplicate an array and how to stringify the (unique) keys for concatenating into a prompt.
I managed to get a working script, but couldn't figure out how to do it without using a couple of temporary text files to pass the data on.
I thought I would post the code in case it may be of help to someone.
Const ForReading = 1, ForWriting = 2, ForAppending = 8, N = 0
Set fso = CreateObject("Scripting.FileSystemObject")
strFilePath = fso.BuildPath(fso.GetAbsolutePathName("."), "\dwgs\logos")
If Not fso.FolderExists(strFilePath) Then
wscript.echo("The LOGO Folder Does Not Exist - Exiting Script")
wscript.quit
End if
'
Set f = fso.OpenTextFile("xtempLogos.txt", ForWriting, True)
Set objShell = CreateObject ("Shell.Application")
Set objFolder = objShell.Namespace (strFilePath)
For Each strFileName in objFolder.Items
a = objFolder.GetDetailsOf (strFileName, N)
a = LEFT(a, (LEN(a)-6))
f.Writeline (a)
Next
f.Close
'
Set f = fso.OpenTextFile("xtempLogos.txt", ForReading)
TheFile = f.ReadAll
f.Close
'
Function mkDic(aK, aV)
Dim tmp : Set tmp = CreateObject("Scripting.Dictionary")
Dim i
For i = 0 To UBound(aK)
tmp(aK(i)) = aV(i)
Next
Set mkDic = tmp
End Function
'
Set f = fso.OpenTextFile("xtempLogos.txt", ForWriting, True)
Dim a : a = Split(TheFile,vbcrlf)
a = Join(mkDic(a, a).Keys)
f.Writeline (a)
f.Close
'
Set f = fso.OpenTextFile("xtempLogos2.txt", ForWriting, True)
Set f = fso.OpenTextFile("xtempLogos.txt", ForReading)
theFile = f.ReadAll
number = 1
myArray = Split(theFile)
for i = 0 to Ubound(MyArray)-1
Set f = fso.OpenTextFile("xtempLogos2.txt", ForAppending, True)
If number < 10 then f.Writeline (number) & ".........." & myArray(i)
If number >=10 then f.Writeline (number) & "........." & myArray(i)
f.Writeline ""
Set f = fso.OpenTextFile("xtempLogos.txt", ForReading, True)
number=number+1
Next
f.Close
'
Set f = fso.OpenTextFile("xtempLogos2.txt", ForReading)
TheFile = f.ReadAll
f.Close
'
user1 = InputBox("WHICH LOGO DO YOU WANT TO ADD?"&(chr(13))&(chr(13))&(chr(13))& (theFile), "Add Logo Script", 11)
choice = (user1) - 1
wscript.echo myArray(choice)
'
Set f = fso.GetFile("xtempLogos.txt")
f.Delete
Set f = fso.GetFile("xtempLogos2.txt")
f.Delete
I am trying to pass folder location as variable to a VBScript which has array to consume the location as a parameter. I don't know how to pass it, could some one please help me?
I am trying to pass following location as a variable "C:\New","C:\New1" to the below code, the script is working fine when I directly give the location, but when I tired to pass it as variable it is not working.
Code given below:
Set oParameters = WScript.Arguments
folderlocation = oParameters(0)
Dim folderarray
Dim WshShell, oExec
Dim wow()
Set objShell = CreateObject("WScript.Shell")
Dim oAPI, oBag
Dim fso, folder, file
Dim searchFileName, renameFileTo, day
Dim i
folderarray = Array(folderlocation)
ii = 0
day = WeekDay(Now())
If day = 3 Then
aa = UBound(folderarray)
f = 0
j = 0
x = 0
Y = 0
For i = 0 To aa
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderarray(i))
For Each file In folder.Files
If InStr(file.Name, name) = 1 Then
ii = 1
strid = file.Name
Set re = New RegExp
re.Pattern = ".*myfile.*"
If re.Test( strid ) Then
'msgbox "File exist and the file name is """ & strid & """"
x = x+1
Else
'msgbox "file not found"
End If
Set re = Nothing
End If
Next
If x = 0 Then
ReDim Preserve wow(f)
wow(f) = folderarray(i)
f = f+1
j = j+1
Else
x = 0
End If
Next
End If
If J > 0 Then
ReDim Preserve wow(f-1)
value = Join(wow, ",")
MsgBox "Files not found in the following location(s) :" & value
Else
MsgBox "fine"
End If
To fill an array from a list of arguments you'd call the script like this:
your.vbs "C:\New" "C:\New1"
and fill the array in your.vbs like this:
size = WScript.Arguments.Unnamed.Count - 1
ReDim folderarray(size)
For i = 0 To size
folderarray(i) = WScript.Arguments.Unnamed.Item(i)
Next
If for some reason you must pass the folder list as a single argument you'd call the script like this:
your.vbs "C:\New,C:\New1"
and populate the array in your.vbs like this:
folderarray = Split(WScript.Arguments.Unnamed.Item(0), ",")
The script I have here is attempting to do recurse through an XML file, storing each RegEx match (stored in a search array) into 2 result arrays; 1 for start date, 1 for end date.
Ubounds of both arrays are checked for equality then the text is passed to a function that uses XMLDOM to find the End_Date node in each parent node, then passes that text to another function, adding 30 days and then passing it back, replacing the previous value. Then it's supposed to write back the contents to the file and save it.
I've got a few problems here. 1. I can't get the +30 day value to be passed back to anything past the first parent node--memory space seems to retain the +30 day value from previous For-Each iteration. 2. I can't write anything back to the file.
I was initially writing for text files, but the format changed to XML as the requirements changed on our project.
I'd love to be able to do this all in XMLDOM in vbscript and just use functions to do specific data changes. But my main concern is my sloppy script not doing the basics.
Can anyone help me by pointing out the flaws in the loops I'm running? I've hit a wall and just can't seem to make any more progress!
Here's the XML file I'm reading(shortened to 2 Ad nodes w/ a ton of child nodes removed):
<?xml version="1.0" encoding="utf-8"?>
<XMLFeederRoot>
<ADS_CREATE_TIME>2016-06-07T01:35:39</ADS_CREATE_TIME>
<Ad>
<Ad_Number>d00524224</Ad_Number>
<Start_Date>2016-08-20T00:00:00</Start_Date>
<End_Date>2016-08-20T00:00:00</End_Date>
<Status>Run</Status>
</Ad><Ad>
<Ad_Number>d00524225</Ad_Number>
<Start_Date>2016-08-20T00:00:00</Start_Date>
<End_Date>2016-08-20T00:00:00</End_Date>
<Status>Run</Status>
</Ad>
</XMLFeederRoot>
Here's the script:
'Setting the Regular Expression object and setting occurrences to all in strings searched.
Set objRegEx= CreateObject("VBScript.RegExp")
objRegEx.Global= True
set Shell= createobject("wscript.shell")
Dim FSO, FLD, FIL, TS, strDate, strEDat, i, d, c
Dim strFolder, strContent, strPath
Const ForReading= 1, ForWriting= 2
strFolder= "C:\Scripts\Run"
Set FSO= CreateObject("Scripting.FileSystemObject")
'Get a reference to the folder you want to search
set FLD= FSO.GetFolder(strFolder)
'loop through the folder and get the files
For Each Fil In FLD.Files
'Open the file to read
Set TS= FSO.OpenTextFile(fil.Path, ForReading)
'Read the contents into a variable
strContent= TS.ReadAll
'Close the file
TS.Close
reDim arrMR(1,1)
arrMR(0,0)= "(\s+)(<Start_Date>(.*?)<\/Start_Date>)"
arrMR(1,0)= "(\s+)(<End_Date>(.*?)<\/End_Date>)"
For i= 0 to Ubound(arrMR)
objRegEx.Pattern= arrMR(i,0)
Set objMatches= objRegEx.Execute(strContent)
d=0
For Each objMatch in objMatches
If i= 0 Then
If d>0 Then
reDim Preserve arrStart(d)
Else
reDim arrStart(d)
End If
arrStart(d)= objMatches.Item(d).SubMatches(2)
'Wscript.Echo arrStart(d)
ElseIf i<> 0 Then
If d>0 Then
reDim Preserve arrEnd(d)
ReDim Preserve arrMatch1(d)
Else
reDim arrEnd(d)
ReDim arrMatch1(d)
End If
arrEnd(d)= objMatches.Item(d).SubMatches(2)
arrMatch1(d)= objMatches.Item(d).SubMatches(1)
End If
If objRegEx.Pattern<> arrMR(0,0) Then
If (ubound(arrStart)= ubound(arrEnd)) Then
'Wscript.Echo "Ubounds Match"
Parse strContent
strContent= Parse(strContent)
Else
'Wscript.Echo "Start & End Dates do not match"
End If
End If
d= d+ 1 'increment to next match
Next
Next
'Close the file
TS.Close
'Open the file to overwrite the contents
Set TS= FSO.OpenTextFile(fil.Path, ForWriting)
'Write the contents back
TS.Write strContent
'Close the current file
TS.Close
Next
'Clean up
Set TS= Nothing
Set FLD= Nothing
Set FSO= Nothing
Function Parse(ParseContent)
'Dim sFSpec : sFSpec = FSO.GetAbsolutePathName("C:\Users\j.levine\Desktop\XML Feeder Scripts\Test_Files\monvid.txt")
Dim oXML : Set oXML = CreateObject("Msxml2.DOMDocument.6.0")
Dim strXMLSDat, strXMLarrStartD, XMLEDat
oXML.setProperty "SelectionLanguage", "XPath"
oXML.async = False
oXML.loadXML(ParseContent)
If 0 = oXML.parseError Then
Dim sXPath3 : sXPath3 = "//XMLFeederRoot/Ad[End_Date=Start_Date]"
Dim ndlFnd : Set ndlFnd = oXML.selectNodes(sXPath3)
If 0 = ndlFnd.length Then
WScript.Echo sXPath, "not found"
ElseIf 0<> ndlFnd.length Then
'WScript.Echo "found", ndlFnd.length, "nodes for", sXPath
Dim ndCur, oldNode
For Each ndCur In ndlFnd
oldNode = oXML.selectsinglenode("//End_Date").text
oldNode= XMLSplitArray(oldNode) 'Pass current Date into Array and add 30 days & return as node text
Set newNode= oXML.selectSingleNode("//End_Date")
newNode.text= oldNode
WScript.Echo ndCur.xml
Next
'WScript.Echo "We have nothing to replace"
End If
Else
WScript.Echo oXML.parseError.reason
End If
Parse= ParseContent
End Function
Function XMLSplitArray(strval1)
dim XmlSA, XmlSA2, XMLEDat
XmlSA = split(strval1, "-")
XmlSA(2) = Left(XmlSA(2), 2)
strXMLDate = XmlSA(1) & "/" & XmlSA(2) & "/" & XmlSA(0)
strXMLDate30 = DateAdd("d", 30, strXMLDate)
XmlSA2 = split(strXMLDate30, "/")
'Add zero to the left
XmlSA2(0)= Right("0" & XmlSA2(0), 2)
XmlSA2(1)= Right("0" & XmlSA2(1), 2)
XmlSA2(1) = XmlSA2(1) & "T00:00:00"
XMLEDat = XmlSA2(2) & "-" & XmlSA2(0) & "-" & XmlSA2(1)
XMLSplitArray= XMLEDat
End Function
Thomas was right w/ the KISS method. I took a big step back, and started over.
Here's what I've come up with. It does what I need regarding the Date+30 and writing back to a file. I think this method is cleaner and will allow me to run my other text massaging through functions.
My questions about this new script are:
1. can this be done without having to write to a new file? Keeping to 1 file is easier.
2. Can I avoid cloning the node and deleting the original one and directly change the original node's value?
3. I seem to be missing how to get that last node <Status> onto it's own line.
Script:
Dim xmlDoc: Set xmlDoc = CreateObject("Msxml2.DOMDocument")
xmlDoc.Async = False
xmlDoc.load "C:\Scripts\Run\MonVid-SHORT.xml"
Dim xmldoc2: set xmldoc2 = CreateObject("Msxml2.DOMDocument")
Dim strSkeleton : strSkeleton= "<?xml version=""1.0"" encoding=""utf-8""?>" & _
"<XMLFeederRoot>" & _
"</XMLFeederRoot>"
xmldoc2.loadXML(strSkeleton)
xmldoc2.save "C:\Scripts\Copy\New_MonVid-Short.xml"
xmlDoc2.async = False
xmlDoc2.load "C:\Scripts\Copy\New_MonVid-Short.xml"
Dim sXPath : sXPath = "/XMLFeederRoot/Ad[Start_Date=End_Date]"
For Each n In XMLDoc.SelectNodes(sXpath)
set l = n.cloneNode(True)
q= l.selectSingleNode("/End_Date").text
strSDat=SplitArray(q)
l.removeChild(l.childNodes.item(2))
set Stat= l.selectSingleNode("/Status")
set Parent= Stat.parentNode
set EDate= xmlDoc2.createElement("End_Date")
EDate.appendChild xmlDoc2.createTextNode(strSDat)
Parent.insertBefore EDate, Stat
xmldoc2.documentElement.appendChild parent
Next
xmlDoc2.save xmldoc2.url
Function SplitArray(strval1)
dim SplitArray1, SplitArray2, strSDat
splitArray1 = split(strval1, "-")
splitArray1(2) = left(splitArray1(2), 2)
strDate1 = SplitArray1(1) & "/" & SplitArray1(2) & "/" & SplitArray1(0)
strDate30 = DateAdd("d", 30, strDate1)
SplitArray2 = split(strDate30, "/")
'Add zero to the left
If Len(SplitArray2(0))<2 Then
SplitArray2(0)= Right("0" & SplitArray2(0), 2)
End If
If Len(SplitArray2(1))<2 Then
SplitArray2(1)= Right("0" & SplitArray2(1), 2)
End If
SplitArray2(1) = splitArray2(1) & "T00:00:00"
strSDat = SplitArray2(2) & "-" & SplitArray2(0) & "-" & SplitArray2(1)
SplitArray= strSDat
End Function
Output File:
<?xml version="1.0" encoding="utf-8"?>
<XMLFeederRoot><Ad>
<Ad_Number>d00524224</Ad_Number>
<Start_Date>2016-08-20T00:00:00</Start_Date>
<End_Date>2016-09-19T00:00:00</End_Date><Status>Run</Status>
</Ad><Ad>
<Ad_Number>d00524225</Ad_Number>
<Start_Date>2016-08-20T00:00:00</Start_Date>
<End_Date>2016-09-19T00:00:00</End_Date><Status>Run</Status>
</Ad>
</XMLFeederRoot>
Since Text and XML files don't use file locks by default just overwrite the original file using xmlDoc.Save monvidPath.
Sub setAdEndDate(monvidPath)
Const sXPath = "/XMLFeederRoot/Ad/End_Date"
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
xmlDoc.Async = "False"
xmlDoc.Load(monvidPath)
Set colNodes=xmlDoc.selectNodes(sXPath)
For Each n In colNodes
n.Text = SplitArray(n.Text)
Next
xmlDoc.Save monvidPath
End Sub
Function SplitArray(strval1)
Dim SplitArray1, SplitArray2, strSDat
splitArray1 = Split(strval1, "-")
splitArray1(2) = Left(splitArray1(2), 2)
strDate1 = SplitArray1(1) & "/" & SplitArray1(2) & "/" & SplitArray1(0)
strDate30 = DateAdd("d", 30, strDate1)
SplitArray2 = Split(strDate30, "/")
'Add zero to the left
If Len(SplitArray2(0))<2 Then
SplitArray2(0)= Right("0" & SplitArray2(0), 2)
End If
If Len(SplitArray2(1))<2 Then
SplitArray2(1)= Right("0" & SplitArray2(1), 2)
End If
SplitArray2(1) = splitArray2(1) & "T00:00:00"
strSDat = SplitArray2(2) & "-" & SplitArray2(0) & "-" & SplitArray2(1)
SplitArray= strSDat
End Function
I am trying to recursively loop through hundreds of directories, and thousands of JPG files to gather sort the files in new folders by date. So far, I am able to individually GetDetailsOf the files using the Shell NameSpace object, and I am also able to recursively loop through directories using the FileSystemObject. However, when I try to put them together in functions, etc, I am getting nothing back when I try to get the DateTaken attribute from the photo.
Here is my code so far:
sFolderPathspec = "C:\LocationOfFiles"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(sFolderPathspec)
Dim arrFiles()
getInfo(objDir)
Sub getInfo(pCurrentDir)
fileCount = 0
For Each strFileName In pCurrentDir.Files
fileCount = fileCount + 1
Next
ReDim arrFiles(fileCount,2)
i=0
For Each aItem In pCurrentDir.Files
wscript.Echo aItem.Name
arrFiles(i,0) = aItem.Name
strFileName = aItem.Name
strDir = pCurrentDir.Path
wscript.echo strDir
dateVar = GetDatePictureTaken(strFileName, strDir)
'dateVar = Temp2 & "_" & Temp3 & "_" & Temp1
arrFiles(i,1) = dateVar
WScript.echo i & "." & "M:" & monthVar & " Y:" & yearVar
WScript.echo i & "." & strFileName & " : " & arrFiles(i,1) & " : " & dateVar
i=i+1
Next
For Each aItem In pCurrentDir.SubFolders
'wscript.Echo aItem.Name & " passing recursively"
getInfo(aItem)
Next
End Sub
Function GetDatePictureTaken(strFileName, strDir)
Set objShell = CreateObject ("Shell.Application")
Set objCurrFolder = objShell.Namespace(strDir)
'wscript.Echo cstr(objCurrFolder.GetDetailsOf(strFileName, 12))
strFileNameDate = cstr(objCurrFolder.GetDetailsOf(strFileName, 12))
strFileNameDate = CleanNonDisplayableCharacters(strFileNameDate)
arrDate = split(strFileNameDate, "/")
'''FAILS HERE WITH A SUBSCRIPT OUT OF RANGE ERROR SINCE IT GETS NULL VALUES BACK FROM THE GET DETAILS OF FUNCTION'''
monthVar = arrDate(0)
yearVar = arrDate(1)
dayVar = arrDate(2)
GetDatePictureTaken = monthVar & "\" & dayVar & "\" & yearVar
End Function
Function CleanNonDisplayableCharacters(strInput)
strTemp = ""
For i = 1 to len(strInput)
strChar = Mid(strInput,i,1)
If Asc(strChar) < 126 and not Asc(strChar) = 63 Then
strTemp = strTemp & strChar
End If
Next
CleanNonDisplayableCharacters = strTemp
End Function
The "Subscript out of range" error when accessing arrDate(0) is caused by arrDate being empty (UBound(arrDate) == -1). As a Split on a non-empty string will return an array, even if the separator is not found, and an attempt to Split Null will raise an "Invalid use of Null" error, we can be sure that strFileNameDate is "".
Possible reason for that:
The index of "Date Picture Taken" is 25 (XP) and not 12 (Win 7) - or whatever came to Mr. Gates' mind for Win 8.
The DPT property is not filled in.
Your cleaning function messed it up.
You have to test for strFileNameDate containing a valid date and decide where to put the files without a valid DPT.
P.S. Instead of doing the recursive loopings, you should consider to use
dir /s/b path\*.jpg > pictures.txt
and to process that file.
I currently have a VBscript that scans a folder for files and moves the files to particular folders depending on key words in the file name.
I need currently the script only scans the one level (ie. doesn't scan recursively) and I need to to search all sub folders too.
Can someone give me a hand with this?
EDIT: Since writing this script I have realized that I need to have this only move files with particular extensions from a particular folder and sub folders to other directories based on the file name.
For example I need only .mp4 and .avi files to be moved.
Can someone help me with this please? I have tried multiple things but still can't get the recursive scanning and moving or the extension specific moving working.
Below is my current script.
'========================================================
' Script to Move Downloaded TV Shows and Movies to
' correct folders based on wildcards in File Name
'========================================================
On Error Resume Next
Dim sTorrents, sTV, sMovie, sFile, oFSO
' create the filesystem object
Set oFSO = WScript.CreateObject("Scripting.FileSystemObject")
' Create Log File
Set objLog = oFSO.OpenTextFile("c:\temp\log.txt", 8, True)
' Set Variables
sTorrents = "C:\Temp\torrents\"
sTV = "C:\Temp\TV Shows\"
sMovie = "C:\Temp\Movies\"
' Scan each file in the folder
For Each sFile In oFSO.GetFolder(sTorrents).Files
' check if the file name contains TV Show Parameters
If InStr(1, sFile.Name, "hdtv", 1) OR InStr(1, sFile.Name, "s0", 1) <> 0 Then
' TV Show Detected - Move File
objLog.WriteLine Now() & " - " & sFile.Name & " Detected as TV Show - Moving to " & sTV
oFSO.MoveFile sTorrents & sFile.Name, sTV & sFile.Name
' Move all other Files to Movies Directory
Else objLog.WriteLine Now() & " - " & sFile.Name & " Detected as Movie - Moving to " & sMovie
oFSO.MoveFile sTorrents & sFile.Name, sMovie & sFile.Name
End If
Next
If sTorrents.File.Count = 0 And sTorrents.SubFolders.Count = 0 Then
objLog.WriteLine Now() & " - There is nothing left to Process..."
objLog.Close
End If
Some notes:
Sub listfolders(startfolder)
Dim fs
Dim fl1
Dim fl2
Set fs = CreateObject("Scripting.FileSystemObject")
Set fl1 = fs.GetFolder(startfolder)
For Each fl2 In fl1.SubFolders
Debug.Print fl2.Path
''process the files
ProcessFiles fl2.Path
'Recursion: lists folders for each subfolder
listfolders fl2.Path
Next
End Sub
''Code copied from question
Sub ProcessFiles(sPath)
' Scan each file in the folder
For Each sFile In oFSO.GetFolder(sPath).Files
' check if the file name contains TV Show Parameters
If InStr(1, sFile.Name, "hdtv", 1) OR InStr(1, sFile.Name, "s0", 1) <> 0 Then
' TV Show Detected - Move File
objLog.WriteLine Now() & " - " _
& sFile.Name & " Detected as TV Show - Moving to " & sTV
oFSO.MoveFile sTorrents & sFile.Name, sTV & sFile.Name
' Move all other Files to Movies Directory
Else
objLog.WriteLine Now() & " - " _
& sFile.Name & " Detected as Movie - Moving to " & sMovie
oFSO.MoveFile sTorrents & sFile.Name, sMovie & sFile.Name
End If
Next
End Sub
before the extension put a * that will find all files with that externsion.
Example: oFSO.MoveFile (PATH\*.EXTERNSION)
here is a recusive function to list files in folders and sub folders
it's tested and working, but you'll probably need some adaptation to your own forkflow. And it's not the most optimized, but it's simple to read
Sub test()
aFiles = F_ListFilesInDirAndSubDir("C:\foo\folder")
'then, add some code to parse the array:
For i = 0 to UBound(aFiles)
'Move or not to move, that is what your code should tell
Next
End Sub
Public Function F_ListFilesInDirAndSubDir(ByVal sDir)
'===============================================================================
'Get the list of files in a directory and in all its sub directories With the full path
'===============================================================================
Dim sChild As String
Dim aFolders As Variant
Dim aFiles As Variant
Dim aChildFiles As Variant
Dim i As Long
Dim j As Long
F_ListFilesInDirAndSubDir = aFiles
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(sDir) Then Exit Function
'Get the files in the directory
aFiles = F_ListFilesInDir(sDir)
'Add the fullpath
For i = 0 To UBound(aFiles)
If aFiles(i) <> "" Then
aFiles(i) = sDir & "\" & CStr(aFiles(i))
End If
Next
'get the folders
aFolders = F_ListFoldersInDir(sDir)
'for each folders, push the files in the file list
For i = 0 To UBound(aFolders)
If aFolders(i) <> "" Then
sChild = sDir & "\" & CStr(aFolders(i))
'Recursive call on each folders
aChildFiles = F_ListFilesInDirAndSubDir(sChild)
'Push new items
For j = 0 To UBound(aChildFiles)
If aChildFiles(j) <> "" Then
ReDim Preserve aFiles(UBound(aFiles) + 1)
aFiles(UBound(aFiles)) = aChildFiles(j)
End If
Next
End If
Next
F_ListFilesInDirAndSubDir = aFiles
End Function
Public Function F_ListFilesInDir(ByVal sDir)
'===============================================================================
'Get the list of files in a directory
'===============================================================================
Dim aList As Variant
Dim i As Long
Dim iChild As Long
Dim oFile
Dim oFolder
Dim oChildren
ReDim aList(0)
F_ListFilesInDir = aList
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(sDir) Then Exit Function
Set oFolder = fs.GetFolder(sDir)
Set oChildren = oFolder.Files
iChild = CDbl(oChildren.Count) - 1
If iChild = -1 Then Exit Function
ReDim aList(iChild)
i = 0
For Each oFile In oChildren
aList(i) = oFile.Name
i = i + 1
Next
F_ListFilesInDir = aList
End Function
Public Function F_ListFoldersInDir(ByVal sDir As String) As Variant
'===============================================================================
'Get the list of folders in a directory
'===============================================================================
Dim aList As Variant
Dim i As Long
Dim oDir
Dim oFolder
Dim oChildren
ReDim aList(0)
F_ListFoldersInDir = aList
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(sDir) Then Exit Function
Set oFolder = fs.GetFolder(sDir)
Set oChildren = oFolder.SubFolders
If oChildren.Count = 0 Then Exit Function
ReDim aList(oChildren.Count - 1)
i = 0
For Each oDir In oChildren
aList(i) = oDir.Name
i = i + 1
Next
F_ListFoldersInDir = aList
End Function