Question

我想将特定的文件类型（* .SLDDRW）从源复制到目标，在目标路径中，我们有很多文件夹和子文件夹。在下面的代码中，我试图在任何子文件夹上移动，但不幸的是，它没有没工作，没有走所有子文件夹，这样可以帮到我吗？

Sub copy_specific_files_in_folder()
Dim FSO As Object
Dim sourcePath As String
Dim destinationPath As String 
Dim fileExtn As String

sourcePath = "C:\Users\6\"
destinationPath = "C:\Users\"

fileExtn = "*.SLDDRW"

If Right (sourcePath, 1) <> "\" Then
sourcePath = sourcePath & "\"
End If

Set FSO = CreateObject ("scripting.filesystemobject")
If FSO.FolderExists(sourcepath) = False  Then 
MsgBox sourcePath & " does not exist"

Exit Sub
End If

  FSO.CopyFile Source:=sourcePath & fileExtn, Destination :=destinationPath
  copy_files_from_subfolders
 MsgBox "Your files have been copied from the sub-folders of " & sourcePath
 End sub




 sub copy_files_from_subfolders()
 Dim FSO AS Object , fld As Object
 Dim fsoFile As Object
 Dim fsoFol As Object

 sourcePath = "C:\Users\6\"
 targetPath = "C:\Users\"

If Right (sourcePath , 1) <> "\"  then sourcePath = sourcePath & "\"
Set FSO = createObject("Scripting.FileSystemObject")
Set fld = FSO.getFolder(sourcePath)
If  FSO.FolderExists(fld)  Then 
    For Each fsoFol  In FSO.GetFolder(sourcePath).SubFolders
        For Each  fsoFile In fsoFol.Files
            If Right (fsoFile, 6)  = "sldprt" Then 
            fsoFile.Copy targetPath
            End If
         Next
      Next
 End If

Answer 1

此功能可以递归搜索文件夹和所有子文件夹中的特定扩展名，然后将找到的文件复制到指定的目的地：

Sub SearchFoldersAndCopy(ByVal arg_sFolderPath As String, _
                         ByVal arg_sDestinationFolder As String, _
                         ByVal arg_sExtension As String)

    Dim oFSO As Object
    Dim oFolder As Object
    Dim oSubFolder As Object
    Dim sTest As String

    'Test if FolderPath exists
    sTest = Dir(arg_sFolderPath, vbDirectory)
    If Len(sTest) = 0 Then
        MsgBox "Specified folder [" & arg_sFolderPath & "] doesn't exist.  Please check spelling or create the directory."
        Exit Sub
    End If

    'Test if Destination exists
    sTest = Dir(arg_sDestinationFolder, vbDirectory)
    If Len(sTest) = 0 Then
        MsgBox "Specified destination [" & arg_sDestinationFolder & "] doesn't exist.  Please check spelling or create the directory."
        Exit Sub
    End If

    'FolderPath and Destination both exist, proceed with search and copy
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(arg_sFolderPath)

    'Test if any files with the Extension exist in directory and copy if one or more found
    sTest = Dir(oFolder.Path & Application.PathSeparator & "*." & arg_sExtension)
    If Len(sTest) > 0 Then oFSO.copyfile oFolder.Path & Application.PathSeparator & "*." & arg_sExtension, arg_sDestinationFolder

    'Recursively search subfolders
    For Each oSubFolder In oFolder.SubFolders
        SearchFoldersAndCopy oSubFolder.Path, arg_sDestinationFolder, arg_sExtension
    Next oSubFolder

End Sub

以下是如何调用它的示例：

Sub tgr()

    Dim sStartFolder As String
    Dim sDestination As String
    Dim sExtension As String

    sStartFolder = "C:\Test"
    sDestination = "C:\Output\"    '<-- The ending \ may be required on some systems
    sExtension = "SLDDRW"

    SearchFoldersAndCopy sStartFolder, sDestination, sExtension

End Sub

我如何在文件夹和子文件夹上行走并获取具有特定文件类型的文件，然后复制到VBA中的另一个目录？

1 个答案: