vbs 遍历一个文件夹并按原来的文件路径和文件名复制到新文件夹

Question

不知道为什么，百度不能发代码！
我把问题发到百度空间里了，
劳烦各位移驾，谢谢！

具体问题请以下链接
http://hi.baidu.com/rscad/item/b30e782b08ff644346996223

Answer 1

Set fso=CreateObject("scripting.filesystemobject")
DestFolderPath="c:\dest" '搜索到的文件 复制的 新文件夹 路径
SearchFolderPath="c:\scr" ' 要搜索 遍历 的文件夹
SearchFileName="123" ' 要搜索的 文件名
dim files(),CopyFilePrefixPath
redim files(0)
call SearchFile(SearchFolderPath,SearchFileName,files,fso)
for i=1 to ubound(files)
CopyFilePrefixPath=Replace(LCase(files(i)),LCase(SearchFolderPath),"")
CopyFilePrefixPath=Replace(LCase(CopyFilePrefixPath),LCase(SearchFileName),"")
If Not CopyFilePrefixPath="" Or Not CopyFilePrefixPath="\" then
If Left(CopyFilePrefixPath,1)="\" Then
CopyFilePrefixPath=Mid(CopyFilePrefixPath,2)
End if
If right(CopyFilePrefixPath,1)="\" Then
CopyFilePrefixPath=Mid(CopyFilePrefixPath,1,Len(CopyFilePrefixPath)-1)
End If
Else
CopyFilePrefixPath=""
End If
call CopyFile(files(i),DestFolderPath,CopyFilePrefixPath,fso)
next
msgbox "已复制 " & ubound(files) & " 个文件！"

Sub CopyFile(SrcFilePath,byval DistFolder,AddCopyFileFrefixPath,fso)
Dim AddPaths,tmp
if not right(DistFolder,1)="\" then DistFolder=DistFolder & "\"
tmp=DistFolder
If AddCopyFileFrefixPath="" then
fso.copyfile SrcFilePath,DistFolder,true
Else
AddPaths=Split(AddCopyFileFrefixPath,"\")
For Each FolPath In AddPaths
tmp=tmp & FolPath & "\"
If not fso.FolderExists(tmp) Then fso.createfolder tmp
Next
fso.copyfile SrcFilePath,DistFolder & AddCopyFileFrefixPath & "\",true
End if
End Sub
Sub SearchFile(FolderPath,ByVal SearchFileName,arrs,fso)
dim FolderObject
SearchFileName=lcase(SearchFileName)
set FolderObject=fso.getfolder(FolderPath)
for each f in FolderObject.files
if SearchFileName=lcase(f.name) then
redim preserve arrs(ubound(arrs)+1)
arrs(ubound(arrs))=f.path
end if
next
for each fol in FolderObject.subfolders
call SearchFile(fol.path,SearchFileName,arrs,fso)
next
set FolderObject=nothing
end sub