使用 Excel VBA 在 Synology NAS 上移动数百个文件夹 - 权限被拒绝错误 70

如何解决使用 Excel VBA 在 Synology NAS 上移动数百个文件夹 - 权限被拒绝错误 70

我父亲 6 年前去世时，他有很多不同版本的文件夹（照片、家庭文件等），他只是不断地从一台计算机复制到另一台计算机，因为他购买了更多的计算机。一旦他买了一台新电脑，他就把文件复制到那台新电脑上，然后把那些文件留在旧电脑里——以防他的新电脑出现故障。他对硬盘做了同样的事情——新硬盘——复制文件。随着时间的推移，他添加了新的照片或文件等。当他通过时，因为当时我有一台 Synology NAS，我努力检查每台计算机，并将所有这些文件移到 NAS - 然后我在我继续时创建了包含这些文件的文件夹。例如，我在他所有的硬盘、电脑等中发现了 44 份我哥哥的婚礼副本。我只真正关心它的 1 份。

这是一种待办事项列表项，通过字面量 TB 的文件夹、文件等来删除所有重复项。我为自己获得了一个重复文件/文件夹清理应用程序，并支付了 ULtrafileSearch Pro 的许可证。我使用后者来查找所有不同的文件夹，例如（照片 - 迪士尼乐园，或照片 - 儿子的婚礼）。我使用 Duplicate File/Folder Cleaner App 尝试查找所有重复文件夹，但由于文件夹种类繁多，此过程有时可能需要数天时间。

我意识到有一个潜在的解决方案。如果我导出 NAS 中的所有文件夹，我可以使用 Excel 来切换所有相似类型的文件夹 - 我想要一些代码来尝试将这些文件夹组合在一起 - 这样我就可以进行查找的工作流程这些情况要容易得多。但是，我遇到了权限被拒绝 - 错误代码 70。我显然对我的 PC 拥有完全权限，它是一个管理员帐户。

Sub Move_Rename_Folder(FromPath As String,ToPath As String,RowNum As Integer)
Dim fso As FileSystemObject
Set fso = New FileSystemObject
'Toggle
If ThisWorkbook.Worksheets("File Mover").Range("A" & RowNum).Value = "No" Then
   
    Exit Sub
End If

If Right(FromPath,1) = "\" Then ' Remove the ends
    FromPath = Left(FromPath,Len(FromPath) - 1)
End If

If Right(ToPath,1) = "\" Then ' Remove the ends
    ToPath = Left(ToPath,Len(ToPath) - 1)
End If

If fso.FolderExists(FromPath) = False Then
    MsgBox FromPath & " doesn't exist"
    Exit Sub
End If

If fso.FolderExists(ToPath) = True Then
    ToPath = ToPath & " " & RowNum ' Add row Number to make a unique directory
End If

fso.MoveFolder Source:=FromPath,Destination:=ToPath
ThisWorkbook.Worksheets("File Mover").Range("E" & RowNum).Value = "YES"

End Sub


Sub MainSub()
 Dim CurrentFrom As Range,CurrentTo As Range,Row As Range

 Set CurrentFrom = ThisWorkbook.Worksheets("File Mover").Range("C4")
 Set CurrentTo = ThisWorkbook.Worksheets("File Mover").Range("D4")
 Set Row = ThisWorkbook.Worksheets("File Mover").Range("B4")

 Dim ToPath As String,FromPath As String,RowNum As Integer
 ToPath = CurrentTo.Value
 FromPath = CurrentFrom.Value
 RowNum = Row.Value
  
  'loop while your current frompath is not empty
 Do While FromPath <> ""
     Call Move_Rename_Folder(FromPath,ToPath,RowNum)
    
     'offsets the cells one row down
     Set CurrentFrom = CurrentFrom.Offset(1,0)
     Set CurrentTo = CurrentTo.Offset(1,0)
     Set Row = Row.Offset(1,0)

     FromPath = CurrentFrom.Value
     ToPath = CurrentTo.Value
     RowNum = Row.Value
    
 Loop
 End Sub

我不想只搜索文件夹，然后选择我要删除的所有文件夹。由于某种原因，一些较旧的文件夹具有独特的文件。