FileSystemObject code has started to throw an error

Question

Not sure why but the following code has begun to throw an unknown error. When the macro is run Excel stops responding.

• Why is this error occuring?
• What is an alternative route with the same functionality?

This code is located within an Excel 2010 xlsm file on a Windows 7 machine.

 Sub CopyFolderToCasinoDirectory()

        'reference Microsoft Scripting Runtime
        On Error Resume Next

        Dim fso As Scripting.FileSystemObject
        Set fso = New Scripting.FileSystemObject
        fso.CopyFolder _
              "\\xxxfileserve\department$\DBA\Opers\All Operators\yyy", _
              "\\xxxfileserve\department$\DBA\Cas\yyy", _
              True

        On Error GoTo 0
        Set fso = Nothing

    End Sub

ok - I've changed the pathways so that it is attempting to move less files - and it hesitates but does eventually run through. I suspect that the above is failing because there are too many files in the directory specified? Currently there are 753 files - maybe too much?

RonDeBruin has given me lots of ideas of how to test or alter the logic. One possibility might be to use DeleteFolder first on the destination folder, and then CopyFolder the target folder over?

Answer 1

Sorry for replying so late. I was not able to get hold of network directories and I wanted to test the code before posting it :)

Try this. Run the Sub Sample() Does it still hang? You will also see the Files getting transferred in a Windows Dialog Box.

Private Declare Function SHFileOperation _
Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long

Private Type SHFILEOPSTRUCT
    hWnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAborted As Boolean
    hNameMaps As Long
    sProgress As String
End Type

Private Const FO_COPY = &H2

Sub Sample()
    Dim path1 As String, path2 As String

    path1 = "\\xxxfileserve\department$\DBA\Opers\All Operators\yyy"
    path2 = "\\xxxfileserve\department$\DBA\Opers\All Operators\yyy"

    If CopyFolder(path1, path2) Then
        MsgBox "Copied"
    Else
        MsgBox "Not copied"
    End If
End Sub

Private Function CopyFolder(ByVal sFrom As String, _
ByVal sTo As String) As Boolean
    Dim SHFileOp As SHFILEOPSTRUCT
    On Error GoTo Whoa
    CopyFolder = False
    With SHFileOp
        .wFunc = FO_COPY
        .pFrom = sFrom
        .pTo = sTo
    End With
    SHFileOperation SHFileOp
    CopyFolder = True
    Exit Function
Whoa:
    MsgBox "Following error occurred while copying folder " & sFrom & vbCrLf & _
    Err.Description, vbExclamation, "Error message"
End Function

Answer 2

There are some points regarding the fso.CopyFolder method:

• If destination does not exist, the source folder and all its contents gets copied. This is the usual case.
• If destination is an existing file, an error occurs.
• If destination is a directory, an attempt is made to copy the folder and all its contents.
• If a file contained in source already exists in destination, an error occurs if overwrite is False. Otherwise, it will attempt to copy the file over the existing file.
• If destination is a read-only directory, an error occurs if an attempt is made to copy an existing read-only file into that directory and overwrite is False.

Make sure not any of these are becoming hindrance for your sub.

But test it another way like this

fso.CopyFolder _
              "\\xxxfileserve\department$\DBA\Opers\All Operators\yyy\*", _
              "\\xxxfileserve\department$\DBA\Cas\yyy", _
              True

---

Hope this helps.