vba - FileSystemObject 代码已经开始抛出错误

Question

不知道为什么，但下面的代码已经开始抛出一个未知错误。当宏运行时，Excel 停止响应。

• 为什么会出现这个错误？
• 具有相同功能的替代路线是什么？

此代码位于 Windows 7 计算机上的 Excel 2010 xlsm 文件中。

 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

好的 - 我已经更改了路径，以便它尝试移动更少的文件 - 它会犹豫但最终会通过。我怀疑上面的失败是因为指定目录中的文件太多？目前有 753 个文件 - 可能太多了？

RonDeBruin给了我很多关于如何测试或改变逻辑的想法。一种可能是首先对目标文件夹使用 DeleteFolder，然后对目标文件夹使用 CopyFolder？

Answer 1

抱歉这么晚才回复。我无法获取网络目录，我想在发布之前测试代码 :)

试试这个。运行 Sub Sample() 它仍然挂起吗？您还将在 Windows 对话框中看到正在传输的文件。

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