|
調べてみたら、ワイルドカードが使えるようなので、
以下のコードでも動きそうです。
Sub test()
Dim Path1 As String, Path2 As String
Dim objFs As Object
Dim objFolder As Object
'環境に合わせて書き直してください
Path1 = "C:\My Documents\test1\"
Path2 = "C:\My Documents\test2\"
Set objFs = CreateObject("Scripting.FileSystemObject")
Call MyFileCopy(objFs.GetFolder(Path1), Path2)
End Sub
Sub MyFileCopy(objFolder As Object, Path As String)
On Error Resume Next
Dim objFs As Object
Set objFs = CreateObject("Scripting.FileSystemObject")
Dim objFile As Object, objSubFolder As Object
Call objFs.Copyfile(objFolder.Path & "\××××*", Path)
For Each objSubFolder In objFolder.SubFolders
Call MyFileCopy(objSubFolder, Path)
Next
End Sub
ただ、同名のファイルが存在した場合を考慮すると、
以下のようにした方がよいかもしれません。
Sub test()
Dim Path1 As String, Path2 As String
Dim objFs As Object
Dim objFolder As Object
'環境に合わせて書き直してください
Path1 = "C:\My Documents\test1\"
Path2 = "C:\My Documents\test2\"
Set objFs = CreateObject("Scripting.FileSystemObject")
Call MyFileCopy(objFs.GetFolder(Path1), Path2)
End Sub
Sub MyFileCopy(objFolder As Object, Path As String)
On Error Resume Next
Dim objFs As Object
Dim objFile As Object, objSubFolder As Object
Dim Mes As String
Set objFs = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFolder.Files
If Left(objFile.Name, 4) = "××××" Then
If objFs.FileExists(Path & objFile.Name) Then
Mes = Path & objFile.Name & "はすでに存在します" & vbCr & "上書きしますか?"
If MsgBox(Mes, vbYesNo) = vbYes Then
Call objFs.Copyfile(objFolder.Path & "\××××*", Path)
End If
Else
Call objFs.Copyfile(objFolder.Path & "\××××*", Path)
End If
End If
Next
For Each objSubFolder In objFolder.SubFolders
Call MyFileCopy(objSubFolder, Path)
Next
End Sub
|
|