I'm trying to delete those folders that are empty with a triple loop.
The order is:
1. Enter into the Main Folder.
2. Check the first encountered folder
3. Check the first subFolder of the main folder.
4. If that subFolder contains another folder, enter in this subSubFolder
5. If it is the last folder and doesn't contain anything, the program deletes it.
5.1 If the folder contains something (a file, excel, pdf, doesn't matter) just go to the next subSubFolder.
6. And goes on until there's no empty folders.
Basically the code must leave untouched the folders that contains a File.
But i don't know why the code doesn't continue and just stop without deleting the empty ones.
This is the Folder Structure:
Folder Path
And this is the code i'm using.:
Sub recursiveDeleting()
Dim sFldr As Object
Dim ssFldr As Object
Dim sssFldr As Object
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
sFound = False
ssFound = False
sssFound = False
flPath = ActiveWorkbook.Path & "\"
YearPath = flPath & "2017\"
FARFIpath = YearPath & "\FAR_FI\"
For Each sFldr In CreateObject("Scripting.FileSystemobject").GetFolder(FARFIpath).SubFolders
For Each ssFldr In CreateObject("Scripting.FileSystemobject").GetFolder(sFldr).SubFolders
For Each sssFldr In CreateObject("Scripting.FileSystemobject").GetFolder(ssFldr).SubFolders
If Dir(sssFldr & "\*.*") = "" Then
RmDir (sssFldr)
Else
sssFound = True
End If
If sssFound = True Then
Exit For
End If
Next sssFldr
If fs.FolderExists(ssFldr) = "" Then
RmDir (ssFldr)
Else
ssFound = True
End If
If ssFound = True Then
Exit For
End If
Next ssFldr
If Dir(sFldr, vbDirectory) = "" Then
RmDir (sFldr)
sFound = True
End If
If sFound = True Then
Exit For
End If
Next sFldr
End Sub
Thanks for your time and have a good day!
Try below code, tested working (it will delete the root folder as well if it's empty afterwards. It can be mind blogging if you are to trace back the recursive code.
Sample - only a blank text file in highlighted folder (all others has no files).
Option Explicit
Private oFSO As Object
Sub DeleteEmptyFolder()
Dim oRootFDR As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oRootFDR = oFSO.GetFolder("C:\Test\mount") '<--- Change to your root folder
If DeleteEmptyFolderOnly(oRootFDR) Then
oRootFDR.Delete
End If
Set oRootFDR = Nothing
Set oFSO = Nothing
End Sub
Private Function DeleteEmptyFolderOnly(ByRef oFDR As Object) As Boolean
Dim bDeleteFolder As Boolean, oSubFDR As Object
bDeleteFolder = False
' Recurse into SubFolders
For Each oSubFDR In oFDR.SubFolders
If DeleteEmptyFolderOnly(oSubFDR) Then
Debug.Print "Delete", oSubFDR.Path ' Comment for production use
oSubFDR.Delete
End If
Next
' Mark ok to delete when no files and subfolders
If oFDR.Files.Count = 0 And oFDR.SubFolders.Count = 0 Then
bDeleteFolder = True
End If
DeleteEmptyFolderOnly = bDeleteFolder
End Function
After the code executed, Folders remained are:
And the immediate window shows the folders that are deleted:
Related
Cannot figure out how to implement the following use case.
I pass a folder and criterias (seperated by a ";") to a function and retrieve a file if criterias were matched.
This is working quite well, but I have an exception:
If the criteria pattern in the first position is "ABC", there are multiple files which could match the search pattern.
My goal is to prioritize the finding in a sense that a file containing "RD_" should have a higher prioritization than a file which contains the string "SD_".
Hint:
If a file has the string "RD_" inside and matches also the other criterias, then the function can stop.
If a file has the string "SD_" inside and matches also the other criterias, then the function should not stop and still loop all files within the folder and try to find a file matching all criterias AND "RD_".
Hope you can help me further.
Sub getTargetFile()
Debug.Print getInputFilePath("D:\", "ABC;11111")
End Sub
Function getInputFilePath(inputDirectoryToScanForFile, filenameCriteria) As String
Dim vSplitCriteria: vSplitCriteria = Split(filenameCriteria, ";") ' Split the criteria into pieces and put them into an array
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Dim sFoundFile As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(inputDirectoryToScanForFile)
Dim blnCorrectFiles As Boolean
For Each oFile In oFolder.Files ' Loop through each file in folder
blnCorrectFiles = True ' assume the current file is correct
'Debug.Print oFile.Name
For i = LBound(vSplitCriteria) To UBound(vSplitCriteria) ' Loop through all file name criteria
If Not InStr(1, UCase(oFile.Name), UCase(vSplitCriteria(i))) > 0 Then ' check whether criteia matched
blnCorrectFiles = False
End If
If blnCorrectFiles = False Then Exit For
Next i
If blnCorrectFiles = True Then ' if all criteria are matched, otherwise it was set to false inbetween the above loop
sFoundFile = oFile.Name
Exit For
End If
Next oFile
If blnCorrectFiles = True Then
getInputFilePath = inputDirectoryToScanForFile & sFoundFile
Else
getInputFilePath = ""
End If
End Function
It sounds like you want to check for RD_ first and then if nothing is found, check for SD_. Which sounds like you just need to run the function twice. Trying to mix and match inside the function would be difficult to generalize and only make things messy.
Sub Prioritize()
Dim Directory As String
Directory = "D:\"
Dim Criteria As String
Criteria = "ABC;11111"
Dim fPath As String
fPath = getInputFilePath(Directory, "RD_;" & Criteria)
If fPath = "" Then fPath = getInputFilePath(Directory, "SD_;" & Criteria)
End Sub
Im trying to check if a folder exists; if it does not then create it. The below is just throwing a run-time error.
Sub AddClose()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myNewFolder As Outlook.Folder
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
If myFolder.Folders("Close") = 0 Then
myFolder.Folders.Add("Close").Folders.Add ("EID1")
myFolder.Folders("Close").Folders.Add ("EID2")
myFolder.Folders("Close").Folders.Add ("EID3")
End If
End Sub
However, If the folder exists then the below works...
If myFolder.Folders("Close") > 0 Then
MsgBox "Yay!"
End If
Why? What can I do to correct the problem?
Firstly, you are comparing the result of the myFolder.Folders("Close") call (which is supposed to return a MAPIFolder object) with an integer (0). You need to use Is Nothing or Is Not Nothing operator.
Secondly, MAPIFolder.Folders.Item() raises an exception if the folder with a given name is not found. You need to trap that exception (as ugly as it is in VBA) and either check the Err.Number value or check that the return object is set:
On Error Resume Next
set subFolder = myFolder.Folders.Item("Close")
if subFolder Is Nothing Then
set subFolder = myFolder.Folders.Add("Close")
End If
I do not understand: If myFolder.Folders("Close") = 0 Then. myFolder.Folders("Close") is a folder and I would not have thought of comparing it against zero. Do you have a reference to a site where this functionality is explained because I would like to understand it?
I wish to create a folder if it does not exist often enough to have written a function. My function does not have ideal parameters for your requirement but it works. I offer it as tested code that does what you want or as a source of ideas for your own code.
Sub DemoGetCreateFldr shows how to use the function GetCreateFldr to achieve the effect I believe you seek.
I do not use GetDefaultFolder because, on my system, it returns a reference to a store I do not use. “Outlook Data File” is Outlook’s default store but the wizard created a separate store for each of my two email addresses. In Set Store = Session.Folders("Outlook Data File"), replace "Outlook Data File" with the name of the store holding the Inbox for which you want to create subfolders.
The first call of GetCreateFldr creates folder “Close” if it does not exist and then creates folder “EID1”. I save the reference to the folder, and use Debug.Print to demonstrate it returns the correct reference.
For folders “EID2” and “EID3”, I do not save the reference which matches your code.
If folders “Close”, “EID1”, “EID2” and “EID3” exist, GetCreateFldr does not attempt to create them although it still returns a reference.
Hope this helps.
Sub DemoGetCreateFldr()
Dim FldrEID1 As Folder
Dim FldrNameFull(1 To 3) As String
Dim Store As Folder
Set Store = Session.Folders("Outlook Data File")
FldrNameFull(1) = "Inbox"
FldrNameFull(2) = "Close"
FldrNameFull(3) = "EID1"
Set FldrEID1 = GetCreateFldr(Store, FldrNameFull)
Debug.Print FldrEID1.Parent.Parent.Parent.Name & "|" & _
FldrEID1.Parent.Parent.Name & "|" & _
FldrEID1.Parent.Name & "|" & _
FldrEID1.Name
FldrNameFull(3) = "EID2"
Call GetCreateFldr(Store, FldrNameFull)
FldrNameFull(3) = "EID3"
Call GetCreateFldr(Store, FldrNameFull)
End Sub
Public Function GetCreateFldr(ByRef Store As Folder, _
ByRef FldrNameFull() As String) As Folder
' * Store identifies the store, which must exist, in which the folder is
' wanted.
' * FldrNameFull identifies a folder which is or is wanted within Store.
' Find the folder if it exists otherwise create it. Either way, return
' a reference to it.
' * If LB is the lower bound of FldrNameFull:
' * FldrNameFull(LB) is the name of a folder that is wanted within Store.
' * FldrNameFull(LB+1) is the name of a folder that is wanted within
' FldrNameFull(LB).
' * FldrNameFull(LB+2) is the name of a folder that is wanted within
' FldrNameFull(LB+1).
' * And so on until the full name of the wanted folder is specified.
' 17Oct16 Date coded not recorded but must be before this date
Dim FldrChld As Folder
Dim FldrCrnt As Folder
Dim ChildExists As Boolean
Dim InxC As Long
Dim InxFN As Long
Set FldrCrnt = Store
For InxFN = LBound(FldrNameFull) To UBound(FldrNameFull)
ChildExists = True
' Is FldrNameFull(InxFN) a child of FldrCrnt?
On Error Resume Next
Set FldrChld = Nothing ' Ensure value is Nothing if following statement fails
Set FldrChld = FldrCrnt.Folders(FldrNameFull(InxFN))
On Error GoTo 0
If FldrChld Is Nothing Then
' Child does not exist
ChildExists = False
Exit For
End If
Set FldrCrnt = FldrChld
Next
If ChildExists Then
' Folder already exists
Else
' Folder does not exist. Create it and any children
Set FldrCrnt = FldrCrnt.Folders.Add(FldrNameFull(InxFN))
For InxFN = InxFN + 1 To UBound(FldrNameFull)
Set FldrCrnt = FldrCrnt.Folders.Add(FldrNameFull(InxFN))
Next
End If
Set GetCreateFldr = FldrCrnt
End Function
Its not a good coding practice to user on error.
I would recommend you to traverse through the folders.
Then if a certain name is not found create it.
The code below part of my macro I use.
It looks for a "Duplicates" under inbox.
It intentionally doesn't do this recursively.
Sub createDuplicatesFolder()
Dim folderObj, rootfolderObj, newfolderObj As Outlook.folder
Dim NameSpaceObj As Outlook.NameSpace
duplicatefolder = False
For Each folderObj In Application.Session.Folders
If folderObj.Name = "Duplicates" Then duplicatefolder = True
Next
If duplicatefolder = False Then
Set rootfolderObj = NameSpaceObj.GetDefaultFolder(olFolderInbox)
Set newfolderObj = rootfolderObj.Folders.Add("Duplicates")
End Sub
A slow way. Depends on number of folders.
Sub checkFolder()
Dim folderObj As folder
Dim rootfolderObj As folder
Dim newfolderObj As folder
Dim checkFolderName As String
' Check and add in the same location
Set rootfolderObj = Session.GetDefaultFolder(olFolderInbox)
' Check and add the same folder name
checkFolderName = "checkedFolder"
For Each folderObj In rootfolderObj.folders
If folderObj.name = checkFolderName Then
Set newfolderObj = rootfolderObj.folders(checkFolderName)
'Reduces the search time, if the folder exists
Exit For
End If
Next
If newfolderObj Is Nothing Then
Set newfolderObj = rootfolderObj.folders.add(checkFolderName)
End If
Debug.Print newfolderObj.name
End Sub
A fast way. Add without checking existing folders.
Sub addFolder_OnErrorResumeNext()
Dim rootFolder As folder
Dim addFolder As folder
Dim addFolderName As String
Set rootFolder = Session.GetDefaultFolder(olFolderInbox)
addFolderName = "addFolder"
On Error Resume Next
' Bypass expected error if folder exists
Set addFolder = rootFolder.folders.add(addFolderName)
' Return to normal error handling for unexpected errors
' Consider mandatory after On Error Resume Next
On Error GoTo 0
' In other cases the expected error should be handled.
' For this case it can be ignored.
Set addFolder = rootFolder.folders(addFolderName)
Debug.Print addFolder.name
End Sub
Kindly do not mark duplicate as I have properly checked for other related solutions specific to Error 91 but none of those seem to fetch me the solution for the problem I am facing .
Am trying to convert my coreldraw files nested in various folders (about 500 files ) using the following VBA code but its either crashing the application or showing the Error 91 'Object or With Block Variable not set'. The same code absolutely works fine when used with the other Demo Set of files which i created to test.
One case I could presume is the file showing some dialog when processing the script. If yes how should I prevent those dialog boxes. Application.DisplayAlerts = False not working in coreldraw.
But however that case is only an assumption. Can someone help me find the problem. Heres the code
Sub NewFolder()
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "My folder Path"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(folder)
Dim SubFolder
For Each SubFolder In folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In folder.Files
If InStr(File.Name, ".cdr") Then
Application.OpenDocument (File)
End If
Dim filepath As String
filepath = ActiveDocument.FullFileName
Dim doc1 As Document
Dim SaveOptions As StructSaveAsOptions
Set SaveOptions = CreateStructSaveAsOptions
Set doc1 = ActiveDocument
With SaveOptions
.EmbedVBAProject = True
.Filter = cdrCDR
.IncludeCMXData = False
.Range = cdrAllPages
.EmbedICCProfile = True
.Version = cdrVersion17
End With
doc1.SaveAs filepath, SaveOptions
doc1.Close
' Operate on each file
Next
End Sub
I'd say you must check if a valid corel draw file has been found
I don't know CorelDraw VBA but I'd assume you could get the following code as a good start:
Sub DoFolder(folder)
Dim SubFolder
For Each SubFolder In folder.SubFolders
DoFolder SubFolder
Next
Dim file
Dim doc1 As Document
Dim filepath As String
Dim SaveOptions As StructSaveAsOptions
For Each file In folder.Files
If InStr(file.Name, ".cdr") Then
Set doc1 = GetDocument(file) '<--| try and get a valid CorelDraw document with the given file: see 'GetDocument()' function at the bottom
If Not doc1 Is Nothing Then '<--| if you succeed then go on with your code
filepath = ActiveDocument.FullFileName
Set SaveOptions = CreateStructSaveAsOptions
With SaveOptions
.EmbedVBAProject = True
.Filter = cdrCDR
.IncludeCMXData = False
.Range = cdrAllPages
.EmbedICCProfile = True
.Version = cdrVersion17
End With
doc1.SaveAs filepath, SaveOptions
doc1.Close
End If
End If
' Operate on each file
Next
End Sub
Function GetDocument(file As Variant) As Document
On Error Resume Next
Set GetDocument = OpenDocument(file)
End Function
as a side note I collected all Dim statements outside loops not to have them run multiple time uselessly
I would like to create a directory and a subdirectory with the following code:
Public fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
fso.CreateFolder ("C:\Users\<my_username>\DataEntry\logs")
I am trying to create nested directories. In this case, the DataEntry directory would not exist, so essentially I would like to create 2 directories, DataEntry\logs under C:\Users\<username>
If I enter command prompt, I can create that directory with mkdir without any issues. However, I simply cannot get VBA to create that folder and I get:
Run-time error '76':
Path not found
I am using Excel VBA 2007/2010
tigeravatar's looping answer might work, but it's a bit hard to read. Instead of micromanaging the string handling yourself, the FileSystemObject has path manipulation functions available, and recursion is slightly easier to read than a loop.
Here is the function I use:
Function CreateFolderRecursive(path As String) As Boolean
Dim FSO As New FileSystemObject
'If the path exists as a file, the function fails.
If FSO.FileExists(path) Then
CreateFolderRecursive = False
Exit Function
End If
'If the path already exists as a folder, don't do anything and return success.
If FSO.FolderExists(path) Then
CreateFolderRecursive = True
Exit Function
End If
'recursively create the parent folder, then if successful create the top folder.
If CreateFolderRecursive(FSO.GetParentFolderName(path)) Then
If FSO.CreateFolder(path) Is Nothing Then
CreateFolderRecursive = False
Else
CreateFolderRecursive = True
End If
Else
CreateFolderRecursive = False
End If
End Function
Need to create each folder one at a time. You can use code like this to do so:
Sub tgr()
Dim strFolderPath As String
Dim strBuildPath As String
Dim varFolder As Variant
strFolderPath = "C:\Users\<my_username>\DataEntry\logs"
If Right(strFolderPath, 1) = "\" Then strFolderPath = Left(strFolderPath, Len(strFolderPath) - 1)
For Each varFolder In Split(strFolderPath, "\")
If Len(strBuildPath) = 0 Then
strBuildPath = varFolder & "\"
Else
strBuildPath = strBuildPath & varFolder & "\"
End If
If Len(Dir(strBuildPath, vbDirectory)) = 0 Then MkDir strBuildPath
Next varFolder
'The full folder path has been created regardless of nested subdirectories
'Continue with your code here
End Sub
Agree with MarkD's suggestion to utilize recursion, it was the code I came here looking to find. In a scenario where the path provided uses a nonexistent root folder it will result in an infinite loop. Adding to MarkD's solution to check for zero length path.
Function CreateFolderRecursive(path As String) As Boolean
Static FSO As FileSystemObject
'Initialize FSO variable if not already setup
If FSO Is Nothing Then Set lFSO = New FileSystemObject
'Is the path paramater populated
If Len(path) = 0 Then
CreateFolderRecursive = False
Exit Function
End If
'If the path exists as a file, the function fails.
If FSO.FileExists(path) Then
CreateFolderRecursive = False
Exit Function
End If
'If the path already exists as a folder, don't do anything and return success.
If FSO.FolderExists(path) Then
CreateFolderRecursive = True
Exit Function
End If
'recursively create the parent folder, then if successful create the top folder.
If CreateFolderRecursive(FSO.GetParentFolderName(path)) Then
If FSO.CreateFolder(path) Is Nothing Then
CreateFolderRecursive = False
Else
CreateFolderRecursive = True
End If
Else
CreateFolderRecursive = False
End If
End Function
I have a vbs script which captures file information and then exports it to a csv file. I need to run the script on main drives such as C:\, E:\, I:\ and more, but each time I run for the main directory I get "Permission Denied" when I try to run it for a subfolder example C:\Program Files it works fine. I have tested this on different desktop machines and servers with full admin accounts and still get it.
What could be the issue with this code. test.vbs
Option Explicit
Dim objFS, objFld
Dim objArgs
Dim strFolder, strDestFile, blnRecursiveSearch
Dim strLines()
Dim i
Dim strCsv
i = 0
' 'Get the commandline parameters
' Set objArgs = WScript.Arguments
' strFolder = objArgs(0)
' strDestFile = objArgs(1)
' blnRecursiveSearch = objArgs(2)
'###################################
'MAKE SURE THESE VALUES ARE CORRECT
'###################################
strFolder = "C:\"
strDestFile = "C:\Output.csv"
blnRecursiveSearch = True
'Create the FileSystemObject
Set objFS=CreateObject("Scripting.FileSystemObject")
'Get the directory you are working in
Set objFld = objFS.GetFolder(strFolder)
'Now get the file details
GetFileDetails objFld, blnRecursiveSearch
'Write the csv file
Set strCsv = objFS.CreateTextFile(strDestFile, True)
strCsv.Write Join(strLines, vbCrLf)
'Close and cleanup objects
strCsv.Close
Set strCsv = Nothing
Set objFld = Nothing
Set strFolder = Nothing
Set objArgs = Nothing
Private Sub GetFileDetails(fold, blnRecursive)
Dim fld, fil
dim strLine(5)
If blnRecursive Then
'Work through all the folders and subfolders
For Each fld In fold.SubFolders
GetFileDetails fld, True
Next
End If
'Now work on the files
For Each fil in fold.Files
strLine(0) = fil.Path
strLine(1) = fil.Type
strLine(2) = fil.Size
strLine(3) = fil.DateCreated
strLine(4) = fil.DateLastModified
strLine(5) = fil.DateLastAccessed
Redim Preserve strLines(i)
strLines(i) = Join(strLine, ",")
i = i + 1
Next
end sub
Please advise and modify code if you know where the issue is.
If it's a permissions problem I would strongly recommend Process Monitor from Sysinternals to diagnose it. You should be able to watch the cscript process (or whatever is executing your script) and find out what kind of permission problem you're having.