vba - 如何使用 FileSystemObject 来“复制和重命名”

Question

在 VB/VBA（或本机 VBA 调用，我猜）中使用FileSystemObject我怎么能：

1. 复制文件夹
2. 重命名文件夹

所以，像：

mFSO.CopyAndRename(targetFolder, copyDirectory, copyFolderName)

我自己基本上已经完成了这个，但我更喜欢更干净的方法调用，例如上面的（和CopyFolder方法）。这似乎有很多代码和很多潜在的故障点......

'
''requires reference to Microsoft Scripting Runtime


Public Function CopyDirectory(ByVal p_copyDirectory As String, p_targetDirectory As String, Optional p_newName As String = "") As Boolean
    CopyDirectory = False
    Dim m_fso 
    Set m_fso = New FileSystemObject

    Dim mFolder, mNewFolder

    If Not Me.DoesPathExist(p_copyDirectory) Then
        Exit Function
    Else

        On Error GoTo errHandler
         Set mFolder = m_fso.GetFolder(p_copyDirectory)
         mFolder.Copy p_targetDirectory, False

         'rename if a "rename" arg is passed
         If p_newName <> "" Then
            If DoesPathExist(p_targetDirectory & mFolder.Name) Then
                Set mNewFolder = m_fso.GetFolder(p_targetDirectory & mFolder.Name)
                mNewFolder.Name = "test" & CStr(Rnd(9999))
            Else
            End If
         End If

         CopyDirectory = True
        On Error GoTo 0

        Exit Function
    End If

errHandler:
    Exit Function

End Function

Answer 1

实际上 Scripting.FileSystemObject 上有一个名为 CopyFolder 的方法。它可用于一步完成复制和重命名，如下所示：

Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.copyFolder "C:\Path\to\source\folder", "C:\Path\to\destination\folder" true

我在这里找到了代码：http: //vba-tutorial.com/copy-a-folder-and-all-of-its-contents/

希望这能回答你的问题。

Answer 2

我的最爱：SHFileOperation API

这也为您提供了正在移动的文件夹的视觉呈现。

Option Explicit

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

Const FO_COPY = &H2 '~~> Copy File/Folder
Const FOF_SILENT = &H4 '~~> Silent Copy

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 Sub Sample()
    Dim lresult  As Long, lFlags   As Long
    Dim SHFileOp As SHFILEOPSTRUCT

    With SHFileOp
        '~~> For Copy
        .wFunc = FO_COPY
        .pFrom = "C:\Temp"
        .pTo = "C:\Temp2\"
        '~~> For Silent Copy
        '.fFlags = FOF_SILENT
    End With
    lresult = SHFileOperation(SHFileOp)

    '~~> SHFileOp.fAborted will be true if user presses cancel during operation
    If lresult <> 0 Or SHFileOp.fAborted Then Exit Sub

    MsgBox "Operation Complete", vbInformation, "File Operations"
End Sub

对于重命名文件夹，这是一个单行

Sub Sample()
    Name "C:\Temp2" As "C:\Temp3"
End Sub

Answer 3

发布此内容以供将来参考。使用这个答案中的语法，我充实了我一直在写的一个类。

我在 VBA 中创建了一个目录管理器类，它可能与将来来到这里的任何人有关。

Private m_fso As New FileSystemObject

'
''requires reference to Microsoft Scripting Runtime

Public Function CopyAndRenameDirectory(ByVal p_copyDirectory As String, p_targetDirectory As String, p_newName As String) As Boolean

    'example
    'p_copyDirectory = "C:\temp\myGoingToBeCopiedDir
    'p_targetDirectory = "C:\Temp2"
    'p_newName = "AwesomeDir"

    'results:
    'myGoingToBeCopiedDir --> C:\Temp2\AwesomeDir

    CopyAndRenameDirectory = False

    p_targetDirectory = p_targetDirectory & "\"

    If Not Me.DoesPathExist(p_copyDirectory) Or Not Me.DoesPathExist(p_targetDirectory) Then
        Exit Function
    End If

    On Error GoTo errHandler
    m_fso.CopyFolder p_copyDirectory, p_targetDirectory & p_newName, True
    On Error GoTo 0

    Exit Function

errHandler:

    If PRINT_DEBUG Then Debug.Print "Error in CopyAndRenameDirectory: " & Err.Description
    Exit Function

End Function

Public Function CopyDirectory(ByVal p_copyDirectory As String, p_targetDirectory As String) As Boolean

    'example
    'p_copyDirectory = "C:\temp\myGoingToBeCopiedDir
    'p_targetDirectory = "C:\Temp2"
    'p_newName = ""

    'results:
    'myGoingToBeCopiedDir --> C:\Temp2\myGoingToBeCopiedDir

    CopyDirectory = False

    If Not Me.DoesPathExist(p_copyDirectory) Or Not Me.DoesPathExist(p_targetDirectory) Then
        Exit Function
    End If

    p_targetDirectory = p_targetDirectory & "\"

    On Error GoTo errHandler
    m_fso.CopyFolder p_copyDirectory, p_targetDirectory, True
    On Error GoTo 0

    Exit Function

errHandler:
    If PRINT_DEBUG Then Debug.Print "Error in CopyDirectory: " & Err.Description
    Exit Function

End Function

Public Function CreateFolder(ByVal p_path As String) As Boolean

    CreateFolder = True

    If Me.DoesPathExist(p_path) Then
        Exit Function
    Else
        On Error GoTo errHandler
        m_fso.CreateFolder p_path ' could there be any error with this, like if the path is really screwed up?
        Exit Function
    End If

errHandler:
        'MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
        CreateFolder = False
        Exit Function

End Function

Public Function DoesPathExist(ByVal p_path As String) As Boolean

    DoesPathExist = False
    If m_fso.FolderExists(p_path) Then DoesPathExist = True

End Function