Filesystemobject permission denied - ways to check / skip? - vba

Question

I have a tool that copies all files from one folder into 10 seperate folders (all stored on different servers).
Sometimes when running this tool, I will get a permission denied error - which I presume comes down to a user being in one of the files that the program tries to overwrite.
Is there a way to confirm where the error occurs, and on top of that.. is there any way to create a report which shows which files were unsuccessful, but continue running after hitting the error?
Hope this makes sense, it is a generic FSO loop (think it was ron de bruin example)
Can you help? Error handling is definitely not my VBA forte!
I have the variables set before this with the filepaths and a seperate macro for each folder that gets copied - here is the code below
Handling the error is more important for me right now as it would let me pinpoint the issue
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
If Right(ToPath2, 1) = "\" Then
ToPath = Left(ToPath2, Len(ToPath) - 1)
End If
If Right(ToPath3, 1) = "\" Then
ToPath = Left(ToPath3, Len(ToPath) - 1)
End If
If Right(ToPath4, 1) = "\" Then
ToPath = Left(ToPath4, Len(ToPath) - 1)
End If
If Right(ToPath5, 1) = "\" Then
ToPath = Left(ToPath5, Len(ToPath) - 1)
End If
If Right(ToPath6, 1) = "\" Then
ToPath = Left(ToPath6, Len(ToPath) - 1)
End If
If Right(ToPath7, 1) = "\" Then
ToPath = Left(ToPath7, Len(ToPath) - 1)
End If
If Right(ToPath8, 1) = "\" Then
ToPath = Left(ToPath8, Len(ToPath) - 1)
End If
If Right(ToPath9, 1) = "\" Then
ToPath = Left(ToPath9, Len(ToPath) - 1)
End If
If Right(ToPath10, 1) = "\" Then
ToPath = Left(ToPath10, Len(ToPath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
FSO.CopyFolder Source:=FromPath, Destination:=ToPath
FSO.CopyFolder Source:=FromPath, Destination:=ToPath2
FSO.CopyFolder Source:=FromPath, Destination:=ToPath3
FSO.CopyFolder Source:=FromPath, Destination:=ToPath4
FSO.CopyFolder Source:=FromPath, Destination:=ToPath5
FSO.CopyFolder Source:=FromPath, Destination:=ToPath6
FSO.CopyFolder Source:=FromPath, Destination:=ToPath7
FSO.CopyFolder Source:=FromPath, Destination:=ToPath8
FSO.CopyFolder Source:=FromPath, Destination:=ToPath9
FSO.CopyFolder Source:=FromPath, Destination:=ToPath10

Answer 1

Let's see if this helps out at all. The idea is to use your FSO to open the destination folder, and attempt to delete each file & subdirectory in the folder. This relies on the helper functions DeleteFile and DeleteFolder.
Module declarations: Important!
Option Explicit
Dim errors As Collection
Dim file As Object 'Scripting.File
Dim fldr As Object 'Scripting.Folder
This is the main procedure, note that you MUST declare all of your variables because of the Option Explicit at the module level.
Sub CopyFolderWithErrorHandling()
Dim FSO As Object 'Scripting.FileSystemObject
Dim paths As Variant
Dim path As Variant
Dim FromPath As String
Dim i As Long
Dim ToPath1$, ToPath2$, ToPath3$, ToPath4$, ToPath5$, ToPath6$, ToPath7$, ToPath8$, ToPath9$, ToPath10$
'!!!### IMPORTANT ###!!!
' Assign all of your "ToPath" variables here:
ToPath1 = "c:\some\path"
'Etc.
Set FSO = CreateObject("scripting.filesystemobject")
Set errors = New Collection
FromPath = "C:\Debug\" '## Modify as needed
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
'## Create an array of destination paths for concise coding
paths = Array(ToPath1, ToPath2, ToPath3, ToPath4, ToPath5, ToPath6, ToPath7, ToPath8, ToPath9, ToPath10)
'## Ensure each path is well-formed:
For i = 0 To UBound(paths)
path = paths(i)
If Right(path, 1) = "\" Then
path = Left(path, Len(path) - 1)
End If
paths(i) = path
Next
'## Attempt to delete the destination paths and identify any file locks
For Each path In paths
'# This funcitno will attempt to delete each file & subdirectory in the folder path
Call DeleteFolder(FSO, path)
Next
'## If there are no errors, then do the copy:
If errors.Count = 0 Then
For Each path In paths
FSO.CopyFolder FromPath, path
Next
Else:
'# inform you of errors, you should modify to print a text file...
Dim str$
For Each e In errors
str = str & e & vbNewLine
Next
'## Create an error log on your desktop
FSO.CreateTextFile(CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\errors.txt").Write str
End If
Set errors = Nothing
End Sub
Helper functions:
The DeleteFolder procedure calls on DeleteFile for each file at its top level, and then calls itself recursively for each subdirectory in the specified folder path, if any.
The DeleteFile procedure logs each error to the errors collection, which we then use to write to a text file on your Desktop.
Sub DeleteFolder(FSO As Object, path As Variant)
'Check each file in the folder
For Each file In FSO.GetFolder(path).Files
Call DeleteFile(FSO, file)
Next
'Check each subdirectory
For Each fldr In FSO.GetFolder(path).SubFolders
Call DeleteFolder(FSO, fldr.path)
Next
End Sub
Sub DeleteFile(FSO As Object, file)
On Error Resume Next
Kill file.path
If Err.Number <> 0 Then
errors.Add file.path
End If
End Sub
Observations
The error log may contain some duplicates, or near-duplicates, as a lock file may be created, e.g. below. These are usually denoted with a tilde character, but since that is legal in a file name, I do not make any attempt to isolate or ignore "duplicates":
c:\my files\excel_file1.xlsx
c:\my files\~excel_file1.xlsx
Certain file types may not raise an error that can be trapped in the above code (.txt for example I think will not error if open in Notepad, etc.). In these cases, the above procedures I think will successfully delete the file, but now you have the risk that the user may save the old version over your newly copied version. I don't know how to prevent this from happening; your problem really is an architecture and replication one, and that is not well-suited to be handled by VBA from Excel...