I am admin to my computer.
I am logged into network.
The below procedure runs and crashes
after line
'XXXXXXXXXXXXXXXXX:
stating the permission is denied, at objFile.Delete.
Why is permission denied?
I am able to delete files and folders from windows explorer.
Why can't the vba program delete it?
Any solutions?
Thanks
Sub RecursiveFolderDelete(MyPath As String)
Dim FileSys As FileSystemObject
Dim objFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set objFolder = FileSys.GetFolder(MyPath)
For Each objFile In objFolder.Files
If Left(objFile.Name, 1) <> "~" And objFile.Name <> ThisWorkbook.Name Then
'XXXXXXXXXXXXXXXXX:
objFile.Delete
End If
Next objFile
Dim Count As Integer
Count = 0
For Each objSubFolder In objFolder.SubFolders
Count = Count + 1
RecursiveFolderDelete MyPath & "\" & objSubFolder.Name
Next objSubFolder
On Error GoTo endx:
If Count = 0 Then
RmDir MyPath
Else
If objFolder.SubFolders.Count = 0 Then
RmDir MyPath
End If
End If
endx:
On Error GoTo 0
Set FileSys = Nothing
Set objFolder = Nothing
Set objSubFolder = Nothing
Set objFile = Nothing
End Sub
Related
I have a code that reads a folder contents (only other folders) and lists them into excel in a certain range.
The problem is that the path where the code reads contents (/CtrExtrase) is given in the code.
I need the path to be choosen by the user. Tried and failed totally.
My code:
Sub distribuire_foldere()
Dim objFSO As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim i As Integer
'CLEARS ALL PREVIOUS CONTENT
Sheets("DISTRIBUIRE foldere").Range("A2:A2000").ClearContents
'INSERTS IN CELL THE PATH WHERE THE SCRIPT IS READING
Sheets("DISTRIBUIRE foldere").Range("$E$1").Value = ThisWorkbook.path & "\CtrExtrase"
' LISTS THE CONTENT OF THE CHOOSEN FOLDER
Application.StatusBar = ""
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
On Error GoTo nuexistafolderul
'THIS IS THE PROBLEM, AS I NEED THE USER TO CHOOSE THE PATH:
Set objFolder = objFSO.GetFolder(Application.ThisWorkbook.path & "\CtrExtrase")
i = 1
'loops through each folder in the directory and prints their names
On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler
For Each objSubFolder In objFolder.subfolders
Application.StatusBar = objSubFolder.path & " " & objSubFolder.Name
'OUTPUTS THE FOLDERS NAME
Cells(i + 1, 1) = objSubFolder.Name
i = i + 1
Next objSubFolder
handleCancel:
If Err = 18 Then
MsgBox "Ai anulat procesul inainte de finalizare! Reia procedura!"
nuexistafolderul:
MsgBox "Nu exista folderul pentru extractia contractelor! Extrage intai contractele!"
End If
'CALLS A MODULE THAT INSERTS CERTAIN TEXT INTO A BATCH FILE
Call Module1.batchfile2
End Sub
Use FileDialog with FolderPicker, here it's wrap in a function :
Function GetFolder(Optional strPath As String = "C:\") As String
Dim fldr As FileDialog
Dim sItem As String
GetFolder = vbNullString
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
And your code, you can set the default path in GetFolder(ThisWorkbook.Path & "\") :
Sub distribuire_foldere()
Dim objFSO As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim i As Integer
'CLEARS ALL PREVIOUS CONTENT
Sheets("DISTRIBUIRE foldere").Range("A2:A2000").ClearContents
'INSERTS IN CELL THE PATH WHERE THE SCRIPT IS READING
Sheets("DISTRIBUIRE foldere").Range("$E$1").Value = ThisWorkbook.Path & "\CtrExtrase"
' LISTS THE CONTENT OF THE CHOOSEN FOLDER
Application.StatusBar = ""
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
On Error GoTo nuexistafolderul
'THIS IS THE PROBLEM, AS I NEED THE USER TO CHOOSE THE PATH:
Set objFolder = objFSO.GetFolder(GetFolder(ThisWorkbook.Path & "\"))
i = 1
'loops through each folder in the directory and prints their names
On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler
For Each objSubFolder In objFolder.SubFolders
Application.StatusBar = objSubFolder.Path & " " & objSubFolder.Name
'OUTPUTS THE FOLDERS NAME
Cells(i + 1, 1) = objSubFolder.Name
i = i + 1
Next objSubFolder
handleCancel:
If Err = 18 Then
MsgBox "Ai anulat procesul inainte de finalizare! Reia procedura!"
nuexistafolderul:
MsgBox "Nu exista folderul pentru extractia contractelor! Extrage intai contractele!"
End If
'CALLS A MODULE THAT INSERTS CERTAIN TEXT INTO A BATCH FILE
Call Module1.batchfile2
End Sub
Working on a macro for Outlook 2007 which selects messages in a folder.
In example 1 and 2 below the customers folder is selected, then a specific customer folder is selected. The method to define the location seems clumsy. Is there a cleaner way to do this?
Right clicking on the sub-folder and selecting properties, the path shown is: "\mailbox-name\customers\customer-xyz". Referencing the path this way in a macro doesn't work. Is it possible to reference the folder location in a more direct manner?
Set olNamespace = olApp.GetNamespace("MAPI")
' Example-1, Select folder by name from default PST inbox
Set FolderKeep = _
olNamespace.GetDefaultFolder(olFolderInbox).Folders("customers").Folders("customer-XYZ")
' Example-2, Select folder by mailbox name/folder/subfolder
Set FolderKeep = _
olNamespace.Folders("mailbox-name").Folders("customers").Folders("customer-XYZ")
A method of pulling the folder out of a path is described here.
http://www.outlookcode.com/d/code/getfolder.htm
Private Function GetFolder(strFolderpath As String) As Folder
' The path argument needs to be in quotation marks and
' exactly match the folder hierarchy that the user sees in the Folder List.
'
' NOTE: If any folder name in the path string contains a "\" character,
' this routine will not work,
'
' As the developer do not use this. It hides errors.
'On Error GoTo GetFolder_Error
Dim objNS As Namespace
Dim objFolder As Folder
Dim arrFolders() As String
Dim colFolders As Folders
Dim i As Long
Dim uErrorMsg As String
' Remove leading slashes, if any
Do While Left(strFolderpath, 1) = "\"
'Debug.Print strFolderpath
strFolderpath = Right(strFolderpath, Len(strFolderpath) - 1)
Loop
Debug.Print strFolderpath
arrFolders() = Split(strFolderpath, "\")
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then Exit For
Next
End If
Set GetFolder = objFolder
ExitRoutine:
Set colFolders = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Exit Function
GetFolder_Error:
uErrorMsg = "Err.Number: " & Err.Number & vbCr & "Err.Description: " & Err.Description
MsgBox uErrorMsg
Set GetFolder = Nothing
Resume ExitRoutine
End Function
Private Sub GetFolder_Test()
Dim testFolder As Folder
Set testFolder = GetFolder("\mailbox-name\customers\customer-xyz")
If Not (testFolder Is Nothing) Then testFolder.Display
End Sub
I want to open all of the files in a certain folder and have it print out the names of those files.
I have set up a code that opens the files but I cannot get it to print the name. I have a separate code that will print the name but will only open one file. I'm failing at combining the two together correctly. Any ideas?
Code that opens all Excel files:
‘set path to progress folder
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
MyFolder = “C:\Users\trembos\Documents\TDS\progress"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While MyFile <> ""
Workbooks.Open fileName:=MyFolder & "\" & MyFile
MyFile = Dir
Loop
End Sub
Code that prints one file name:
'set path to TDS_Working
Sub TDS()
Workbooks.Open ("C:\Users\trembos\Documents\TDS\progress")
End Sub
'set up dim
Sub LoopThroughDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder("C:\Users\trembos\Documents\TDS\progress\")
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 1) = objFile.Name
Next objFile
End Sub
This should work smoothly :
Sub LoopThroughDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder As String
Dim Sht As Worksheet
Dim i As Integer
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
Set Sht = ActiveSheet
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) <> "xls" And LCase(Left(Right(objFile.Name, 4), 3)) <> "xls" Then
Else
'print file name
Sht.Cells(i + 1, 1) = objFile.Name
i = i + 1
Workbooks.Open Filename:=MyFolder & objFile.Name
End If
Next objFile
End Sub
You just need to iterate i inside the loop: i=i+1.
‘set path to progress folder
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
ActiveSheet.Unprotect ("password")
MyFolder = “C:\Users\trembos\Documents\TDS\progress"
MyFile = Dir(MyFolder & "\*.xlsx")
i=1
Do While MyFile <> ""
Workbooks.Open fileName:=MyFolder & "\" & MyFile
MyFile = Dir
Cells(i + 1, 1) =Myfile
i=i+1
Loop
ActiveSheet.Protect ("password")
End Sub
Does this not work?
Can someone help me with VBA code to rename the subfolder with the part of file name as given below
Folder : C:\Test
Sub folders : C:\Test\a , C:\Test\b , C:\Test\a .... Goes on
It has some file contents and I have to match a file with name starting with VDX_000674 and get last 4 characters and rename the Folder with that.
I have tried the below code but with no use any edits will be appreciated
Sub Rename()
Call Test_Rename("C:\Users\shanmso\Desktop\VN\Output")
End Sub
Sub Test_Rename(MyPath As String)
Dim FileSys As FileSystemObject
Dim objFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
Dim Riname As String
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set objFolder = FileSys.GetFolder(MyPath)
For Each objFile In objFolder.Files
If Left(objFile.Name, 15) = "DEX-VH_00000374" Then
Riname = Mid(objFile.Name, 17, 3)
Name objFolder As Riname
Exit For
End If
Next objFile
For Each objSubFolder In objFolder.SubFolders
Test_Rename MyPath & "\" & objSubFolder.Name
Next objSubFolder
Set FileSys = Nothing
Set objFolder = Nothing
Set objSubFolder = Nothing
Set objFile = Nothing
End Sub
untested. but I think FreeMan is right Name objFolder As Riname should be something more like this Call MkDir(MyPath & "\" & Riname)
Also I don't think you need the second For Each loop so I removed it. I'm guessing you thought this was actually creating the subfolders, but it isn't. Its easier to just rename the folders in the first For each loop
Sub Test_Rename(MyPath As String)
Dim FileSys As FileSystemObject
Dim objFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
Dim Riname As String
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set objFolder = FileSys.GetFolder(MyPath)
For Each objFile In objFolder.Files
If Left(objFile.Name, 15) = "DEX-VH_00000374" Then
Riname = Mid(objFile.Name, 17, 3)
Call MkDir(MyPath & "\" & Riname)
Exit For
End If
Next objFile
Set FileSys = Nothing
Set objFolder = Nothing
Set objSubFolder = Nothing
Set objFile = Nothing
End Sub
I am looking to write a VB script to keep a folder tidy up. The rules are:
Check if any file was changed today
If at least one file was changed today move all the files last changed 2 days ago to another folder
This is what I have so far:
strFolder = "c:\testdelete"
objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strFolder)
Set colFiles = objFolder.Files
For Each objFile In colFiles
If DateDiff("N",objFile.DateLastModified,Now()) > 4320 Then
objFSO.DeleteFile(objFile),True End if Next
This however is not working.
Iterate over the files in the folder while
building a list of the files modified at least 2 days ago, and
checking if a file was modified today.
Something like this should work:
Set fso = CreateObject("Scripting.FileSystemObject")
Set oldFiles = CreateObject("System.Collections.ArrayList")
today = Date
threshold = Date - 1
fileModifiedToday = False
For Each f In fso.GetFolder("C:\some\folder").Files
If f.DateLastModified >= today Then fileModifiedToday = True
If f.DateLastModified < threshold Then oldFiles.Add f
Next
If fileModifiedToday Then
For Each f In oldFiles
f.Move "C:\other\folder\"
Next
End If
So to compare the dates of the file and the current day you can utilize the DateValue() Function which returns only the date of the DateTime variable. Then you can utilize the MoveFile command which works like objFSO.MoveFile(FileObject, DestinationFolder)
Dim strFolder, Dest
On Error Resume Next 'Move to manual error handling.
strFolder = "c:\testdelete"
Dest = "C:\testmove"
Dim objFSO, objFolder, colFiles, objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strFolder)
Set colFiles = objFolder.Files
For Each objFile In colFiles
If DateValue(objFile.DateLastModified) = DateValue(Now) Then
objFSO.MoveFile(objFile, Dest)
if err.number <> 0 then msgbox "Destination does not exist"
err.clear
ElseIf DateDiff("N",objFile.DateLastModified,Now()) > 4320 Then
objFSO.DeleteFile(objFile,True)
if err.number <> 0 then msgbox "Unable to delete file"
err.clear
End if
Next