复制文件夹和所有子文件夹，而不覆盖现有的

Question

0

我正在尝试使用 fso.folder 副本在网络驱动器上创建备份数据库。我的目的是移动文件夹中的所有文件和子文件夹，但如果备份驱动器上已存在文件，请跳过它，然后复制文件夹中的其余文件。

FSO.copyfolder Source:=Sourcefilename, Destination:=Destinfilename, OverwriteFiles:= False

但是，脚本在找到现有文件时出错。任何建议将不胜感激。

Answer 1

不覆盖的备份文件夹及其子文件夹

• 以下内容会将源文件夹备份到目标文件夹，即复制丢失的文件夹和文件。
• TESTcopyFolder 只是您如何使用该解决方案的一个示例。
• 它将调用初始化过程backupFolder，必要时将调用backupFolderCopy和backupFolderRecurse。
• 声明Private SkipPath As String 和三个过程必须复制到同一个（通常是标准的）模块，例如Module1。

守则

Option Explicit

Private SkipPath As String

Sub TESTcopyFolder()
     
    Const srcPath As String = "F:\Test\2020\65412587\Test1"
    Const dstPath As String = "F:\Test\2020\65412587\Test2"
     
    backupFolder srcPath, dstPath
    
    ' Open Destination Path in File Explorer.
    'ThisWorkbook.FollowHyperlink dstPath

End Sub

' Initialize
Sub backupFolder( _
    ByVal srcPath As String, _
    ByVal dstPath As String, _
    Optional ByVal backupSubFolders As Boolean = True)
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    With fso
        If .FolderExists(srcPath) Then
            backupFolderCopy fso, srcPath, dstPath
            If backupSubFolders Then
                SkipPath = ""
                backupFolderRecurse fso, srcPath, dstPath
            End If
            MsgBox "Backup updated.", vbInformation, "Success"
        Else
            MsgBox "Source Folder does not exist.", vbCritical, "No Source"
        End If
    End With

End Sub

' Copy Folders
Private Function backupFolderCopy( _
    fso As Object, _
    ByVal srcPath As String, _
    ByVal dstPath As String) _
As String
    
    With fso
        If .FolderExists(dstPath) Then
            Dim fsoFile As Object
            Dim dstFilePath As String
            For Each fsoFile In .GetFolder(srcPath).Files
                dstFilePath = .BuildPath(dstPath, fsoFile.Name)
                ' Or:
                'dstFilePath = Replace(fsoFile.Path, srcPath, dstPath)
                If Not .FileExists(dstFilePath) Then
                    .CopyFile fsoFile.Path, dstFilePath
                End If
            Next fsoFile
            'backupFolderCopy = "" ' redundant: it is "" by default.
        Else
            .CopyFolder srcPath, dstPath
            backupFolderCopy = srcPath
        End If
    End With

End Function

' Copy SubFolders
Private Sub backupFolderRecurse( _
        fso As Object, _
        ByVal srcPath As String, _
        ByVal dstPath As String)
    
    Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(srcPath)
    
    Dim fsoSubFolder As Object
    Dim srcNew As String
    Dim dstNew As String
    
    For Each fsoSubFolder In fsoFolder.SubFolders
        srcNew = fsoSubFolder.Path
        dstNew = fso.BuildPath(dstPath, fsoSubFolder.Name)
        ' Or:
        'dstNew = Replace(srcNew, srcPath, dstPath)
        If Len(SkipPath) = 0 Or Left(srcNew, Len(SkipPath)) <> SkipPath Then
            SkipPath = backupFolderCopy(fso, srcNew, dstNew)
            backupFolderRecurse fso, srcNew, dstNew
        End If
    Next

End Sub

Answer 2

请尝试下一个代码：

Sub testCopyFolder()
 Dim FSO As Object, SourceFold As String, DestinationFold As String
 
 SourceFold = "Source folder path"           ' ending in "\"
 DestinationFold = "Destination folder path" ' ending in "\"
 Set FSO = CreateObject("Scripting.FileSystemObject")
 
 If Not FSO.FolderExists(DestinationFold) Then
    FSO.CopyFolder SourceFold, DestinationFold
 End If
End Sub

您可以以类似的方式继续复制文件。当然，使用FSO.FileExists()...