Ive been searching for this for like decades with no success.
I need to find out if a subdfolder that i ve given the name is exist..
For i = 0 To 3 'got 4 different loc to check sub folders
Set f = fso.GetFolder(backupdir(i))
Set sf = f.SubFolders
For Each fr In sf 'for each folder in sub folder
Do Until fr = "" Or fr = Null
If fso.FolderExists(fr.SubFolders) Then
'if more sub folders exist i wanna make sure
'that i can get their subfolders too
'till there is no sub folder left..
sf = fr
End If
Loop
Next fr
Next i
Actions like traversing the folders-of-a-folder-of-a-folder... is called recursing.
The FindFirstFile: Recursive Search for Folders Using a Folder Mask (minimal code) example here shows how to do this quickly with the windows API.
Check this code.
Dim FolderList As String
Private Sub SubCheck1(folderToCheck As String)
Dim fso, f, f1, s, sf
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(folderToCheck)
Set sf = f.SubFolders
For Each f1 In sf
FolderList = FolderList & "|" & f1.Name
Call SubCheck1(f1.Path)
Next
End Sub
Private Sub Form_Load()
Call SubCheck1("c:\folderToSearch")
Debug.Print FolderList
End Sub
This code gets all the subfolders in the specified directory(c:\folderToSearch in this case) and writes them into the string FolderList with a "|" seperator.
You can also use an array instead of separating folder names with a "|".
Or you can add the code below after the Debug.Print FolderList line in Form_Load to get an array:
myArray = split(FolderList, "|")
You can "recurse" subfolders with a collection and standard Dir function in 20 lines of code like this
Private Sub Command1_Click()
Dim vElem As Variant
For Each vElem In pvGetFolders("C:\TEMP")
Debug.Print vElem
Next
End Sub
Private Function pvGetFolders(ByVal sRoot As String) As Collection
Dim lIdx As Long
Dim sFile As String
Set pvGetFolders = New Collection
pvGetFolders.Add sRoot
Do While lIdx < pvGetFolders.Count
lIdx = lIdx + 1
sFile = Dir(pvGetFolders.Item(lIdx) & "\*.*", vbDirectory)
Do While LenB(sFile) <> 0
If sFile <> "." And sFile <> ".." Then
sFile = pvGetFolders.Item(lIdx) & "\" & sFile
If (GetAttr(sFile) And vbDirectory) <> 0 Then
pvGetFolders.Add sFile
End If
End If
sFile = Dir
Loop
Loop
pvGetFolders.Remove 1
End Function
You could use WMI. You could search in CIM_Directory, I believe the field name is "name",
and if it contains the folder or partially the foldername you are looking for, return the full name.
Related
I'm organizing my photos so I would like a VBscript that can Write all TAGs from my photos in a Txt file. The Script Will read the Tags from the photos that are saved on different subfolders and Write all the Tags without repetions, so I can have a list of unique Tags on this file.
The txtFile will be saved on same directory of the Vbs file.
My folder has subfolders.
The following code was developed to be used on Excel (VBA). I tried to translate it to VBS but without success. Credits to MVP Rick Rothstein.
I guess it is a start if we can modify the code to VBS.
Sub UniqueTextFileItems()
Dim R As Long, FileNum As Long, TotalFile As String, Data As Variant
FileNum = FreeFile
Open "c:\temp\test.txt" For Binary As #FileNum
TotalFile = Space(LOF(FileNum))
Get #FileNum , , TotalFile
Close #FileNum
Data = Split(Join(Split(TotalFile, vbCrLf), ","), ",")
With CreateObject("Scripting.Dictionary")
For R = 0 To UBound(Data)
If Len(Data(R)) Then .Item(Data(R)) = 1
Next
Data = .Keys
End With
With CreateObject("System.Collections.ArrayList")
For R = 0 To UBound(Data)
.Add Data(R)
Next
.Sort
Range("A1").Resize(.Count) = Application.Transpose(.ToArray)
End With
End Sub
Searching in this forum I found the amazing code below for getting the unique values from arrays.
Getting Unique Values from Arrays
Now I need to know how to solve the problem on line code inside the loop:
Set objDirectory = objShell.Namespace(vFile)
Dim myArr As Variant
Sub TestFunction()
Dim colFiles As New Collection
Dim MyPath As String
MyPath = "C:\Photos"
ReDim Preserve myArr(0)
RecursiveDir colFiles, MyPath, "*.jpg", True
Dim objShell: Set objShell = CreateObject("Shell.Application")
Dim objDirectory
Dim vFile As Variant
For Each vFile In colFiles
'I'm getting Error here - I cannot dynamically refer the namespace
Set objDirectory = objShell.Namespace(vFile)
ReDim Preserve myArr(UBound(myArr) + 1)
If Len(Trim(objDirectory.GetDetailsOf(vrFile, 18))) > 0 Then
myArr(UBound(myArr)) = objDirectory.GetDetailsOf(vrFile, 18)
Else
End If
Next vFile
End Sub
Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
I use the following code to let the user select a folder then list the last time each file within was modified (one column for day and another for time). The third column is for the names of the files.
Sub ListFils()
Dim f As Object, fso As Object, flder As Object
Dim folder As String
Dim wb As Workbook, ws As Worksheet
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Cancel Selected"
End
End If
folder = .SelectedItems(1)
End With
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
For Each f In fso.GetFolder(folder).Files
ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0) = f.DateLastModified
ws.Range("B" & ws.Rows.Count).End(xlUp).Offset(1, 0) = f.DateLastModified
ws.Range("C" & ws.Rows.Count).End(xlUp).Offset(1, 0) = f.Name
Next
Columns("A:C").Columns.AutoFit
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
End Sub
The code works on Windows but does not work on Mac. Any ideas how I can get it to work?
As Tim said in his comment, the line Set fso = CreateObject("Scripting.FileSystemObject"), and anything that relies on fso will not work on mac, but you can use Dir() to get file names, and FileDateTime("filename") to get the modified date.
I need a quick script do two parts.
Run a windows executable
Delete files within a folder and subfolders (*.jpg, *.img).
The first part of the below script works (running the executable) but I am getting stuck on part 2. I get
Cannot use parentheses when calling a sub
The error is on the line with the RecursiveDelete call. I actually cut and pasted that code from another SO question. I have googled the error but still don't understand.
Can anybody know how to get this script working?
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run chr(34) & "C:\Users\acer\Desktop\CT\process.exe" & Chr(34), 0
Set WshShell = Nothing
Dim PicArray(2)
Dim p
PicArray(1) = "*.jpg"
PicArray(2) = "*.img"
For p = 1 To 2
RecursiveDelete ("D:\pictures", PicArray(p))
Next p
Private Sub RecursiveDelete(ByVal Path As String, ByVal Filter As String)
Dim s
For Each s In System.IO.Directory.GetDirectories(Path)
try
RecursiveDelete(s, Filter)
catch dirEx as exception
debug.writeline("Cannot Access " & s & " : " & dirEx.message
end try
Next
For Each s In System.IO.Directory.GetFiles(Path, Filter)
try
System.IO.File.Delete(s)
catch ex as exception
debug.writeline("Cannot delete " & s & " : " & ex.message)
end try
Next
End Sub
Update: Revised answer from Hackoo that works great.
Option Explicit
Dim fso,RootFolder, wshShell
set fso = CreateObject("Scripting.FileSystemObject")
RootFolder = "D:\pictures"
Set RootFolder = fso.GetFolder(RootFolder)
Call RecursiveDelete(RootFolder)
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run chr(34) & "C:\process.exe" & Chr(34), 0
Set WshShell = Nothing
'*****************************************************************************
Function RecursiveDelete(Folder)
Dim File,MyFile,Ext,i,SubFolder
Set Folder = fso.GetFolder(Folder)
For each File in Folder.Files
Set MyFile = fso.GetFile(File)
Ext = Array("iMG","JPG")
For i = LBound(Ext) To UBound(Ext)
If LCase(fso.GetExtensionName(File.name)) = LCase(Ext(i)) Then
MyFile.Delete()
Exit For
end if
Next
Next
For each SubFolder in Folder.SubFolders
Call RecursiveDelete(SubFolder)
Next
End Function
'*****************************************************************************
Try like this way :
Option Explicit
Dim fso,RootFolder
set fso = CreateObject("Scripting.FileSystemObject")
RootFolder = "D:\pictures"
Set RootFolder = fso.GetFolder(RootFolder)
Call RecursiveDelete(RootFolder)
Msgbox "Pictures Cleaned !",vbInformation,"Pictures Cleaned !"
'*****************************************************************************
Function RecursiveDelete(Folder)
Dim File,MyFile,Ext,i,SubFolder
Set Folder = fso.GetFolder(Folder)
For each File in Folder.Files
Set MyFile = fso.GetFile(File)
Ext = Array("jpg","img")
For i = LBound(Ext) To UBound(Ext)
If LCase(fso.GetExtensionName(File.name)) = LCase(Ext(i)) Then
MyFile.Delete()
Exit For
end if
Next
Next
For each SubFolder in Folder.SubFolders
Call RecursiveDelete(SubFolder)
Next
End Function
'*****************************************************************************
Instead of passing the array item into RecursiveDelete, obtain the contents of the array item into a variable within the loop, and pass that variable instead.
Code would be similar to this- did not have a chance to test syntax.
For p = 1 To 2
Dim PicItem
PicItem = PicArray(p)
RecursiveDelete ("D:\pictures", PicItem )
Next p
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
What is the simplest way in VB6 to loop through all the files in a specified folder directory and get their names?
sFilename = Dir(sFoldername)
Do While sFilename > ""
debug.print sFilename
sFilename = Dir()
Loop
Dim fso As New FileSystemObject
Dim fld As Folder
Dim fil As File
Set fld = fso.GetFolder("C:\My Folder")
For Each fil In fld.Files
Debug.Print fil.Name
Next
Set fil = Nothing
Set fld = Nothing
Set fso = Nothing
DJ's solution is simple and effective, just throwing out another one in case you need a little more functionality that the FileSystemObject can provide (requires a reference to the Microsoft Scripting Runtime).
Dim fso As New FileSystemObject
Dim fil As File
For Each fil In fso.GetFolder("C:\").Files
Debug.Print fil.Name
Next
'For VB6 very Tricky:
'Simply get the location of all project .frm files saved in your disk/project directory
Dim CountVal As Integer
CountVal = 0
cbo.Clear
sFilename = Dir(App.Path & "\Forms\")
Do While sFilename > ""
If (Right(sFilename, 4) = ".frm") Then
cbo.List(CountVal) = Left(sFilename, (Len(sFilename) - 4))
CountVal = CountVal + 1
End If
sFilename = Dir()
Loop
create button with name = browseButton
create filelistbox with name = List1
double click on button in design
and code should look like this
Private Sub browseButton_Click()
Dim path As String
path = "C:\My Folder"
List1.path() = path
List1.Pattern = "*.txt"
End Sub
done now run it
You can use the following demo code,
Dim fso As New FileSystemObject
Dim fld As Folder
Dim file As File
Set fld = fso.GetFolder("C:\vishnu")
For Each file In fld.Files
msgbox file.Name
Next