VB复制整个磁盘下的文件,包括子文件夹,不要调用CMD命令
最好可以调用API函数,要能够判断复制是否成功,不要调用批处理和一些除VB本身代码之外的。没看明白的就不用回答了,代码拖拖拉拉一大堆的也不用回答了,150分诚心寻求VB高...
最好可以调用API函数,要能够判断复制是否成功,不要调用批处理和一些除VB本身代码之外的。
没看明白的就不用回答了,代码拖拖拉拉一大堆的也不用回答了,150分诚心寻求VB高手回答问题(剩下的50分我满意再加)。在线等半小时 展开
没看明白的就不用回答了,代码拖拖拉拉一大堆的也不用回答了,150分诚心寻求VB高手回答问题(剩下的50分我满意再加)。在线等半小时 展开
1个回答
2013-12-12
展开全部
在VB代码输入区复制下面代码,运行即可。
Option Explicit
Dim SrcFolder As String, DstFolder As String, FileName As String, S As String
Dim fs, folder, subfolders, Files, File, i, j
Public Function CreateDirectory(ByVal strPath As String) As Boolean
Dim i As Integer
Dim CurrentDir As String
On Error GoTo err
Dim strT() As String
If Dir(strPath, vbDirectory) <> "" Then
'如果目录存在,直接返回
CreateDirectory = True
Exit Function
End If
If Dir(strPath) <> "" Then Exit Function
If Right(strPath, 1) = "\\" Then
'去掉最右边的""
strPath = Left(strPath, Len(strPath) - 1)
End If
If InStr(strPath, "\\") = 0 Then Exit Function
'无子目录
strT = Split(strPath, "\\")
CurrentDir = strT(0)
For i = 1 To UBound(strT)
If Dir(CurrentDir & "\\" & strT(i), vbDirectory) = "" Then
MkDir CurrentDir & "\\" & strT(i)
CurrentDir = CurrentDir & "\\" & strT(i)
End If
Next
CreateDirectory = True
Exit Function
err:
'此处如果出错,很有可能就是目录名中包含了系统不支持的字符,比如说* / & 等
End Function
Function digui(path)
Set folder = fs.GetFolder(path)
Set subfolders = folder.subfolders
Set Files = folder.Files
For Each i In Files
If InStr(1, i.Name, FileName, 1) Then '如果发现符合特征的文件
S = Mid(i.path, InStr(i.path, "\\"))
S = Left(S, InStrRev(S, i.Name, , vbTextCompare) - 1)
If Right(S, 1) = "\\" Then S = Left(S, Len(S) - 1)
S = DstFolder & S
CreateDirectory S
FileCopy i.path, S & "\\" & i.Name '则复制
End If
DoEvents
Next
For Each j In subfolders
digui (j.path)
DoEvents
Next
End Function
Private Sub Form_Load()
SrcFolder = InputBox("请输入源盘", "第1步", "D:")
If SrcFolder = "" Then End
DstFolder = InputBox("请输入目标盘", "第2步", "E:")
If DstFolder = "" Then End
If Right(DstFolder, 1) = "\\" Then DstFolder = Left(DstFolder, Len(DstFolder) - 1)
FileName = InputBox("请输入文件名特征", "第3步", ".Mp3")
If FileName = "" Then End
FileName = Replace(FileName, "*", "")
Set fs = CreateObject("scripting.filesystemobject")
digui (SrcFolder)
MsgBox "文件复制结束!", vbInformation, "恭喜你"
End
End Sub
Option Explicit
Dim SrcFolder As String, DstFolder As String, FileName As String, S As String
Dim fs, folder, subfolders, Files, File, i, j
Public Function CreateDirectory(ByVal strPath As String) As Boolean
Dim i As Integer
Dim CurrentDir As String
On Error GoTo err
Dim strT() As String
If Dir(strPath, vbDirectory) <> "" Then
'如果目录存在,直接返回
CreateDirectory = True
Exit Function
End If
If Dir(strPath) <> "" Then Exit Function
If Right(strPath, 1) = "\\" Then
'去掉最右边的""
strPath = Left(strPath, Len(strPath) - 1)
End If
If InStr(strPath, "\\") = 0 Then Exit Function
'无子目录
strT = Split(strPath, "\\")
CurrentDir = strT(0)
For i = 1 To UBound(strT)
If Dir(CurrentDir & "\\" & strT(i), vbDirectory) = "" Then
MkDir CurrentDir & "\\" & strT(i)
CurrentDir = CurrentDir & "\\" & strT(i)
End If
Next
CreateDirectory = True
Exit Function
err:
'此处如果出错,很有可能就是目录名中包含了系统不支持的字符,比如说* / & 等
End Function
Function digui(path)
Set folder = fs.GetFolder(path)
Set subfolders = folder.subfolders
Set Files = folder.Files
For Each i In Files
If InStr(1, i.Name, FileName, 1) Then '如果发现符合特征的文件
S = Mid(i.path, InStr(i.path, "\\"))
S = Left(S, InStrRev(S, i.Name, , vbTextCompare) - 1)
If Right(S, 1) = "\\" Then S = Left(S, Len(S) - 1)
S = DstFolder & S
CreateDirectory S
FileCopy i.path, S & "\\" & i.Name '则复制
End If
DoEvents
Next
For Each j In subfolders
digui (j.path)
DoEvents
Next
End Function
Private Sub Form_Load()
SrcFolder = InputBox("请输入源盘", "第1步", "D:")
If SrcFolder = "" Then End
DstFolder = InputBox("请输入目标盘", "第2步", "E:")
If DstFolder = "" Then End
If Right(DstFolder, 1) = "\\" Then DstFolder = Left(DstFolder, Len(DstFolder) - 1)
FileName = InputBox("请输入文件名特征", "第3步", ".Mp3")
If FileName = "" Then End
FileName = Replace(FileName, "*", "")
Set fs = CreateObject("scripting.filesystemobject")
digui (SrcFolder)
MsgBox "文件复制结束!", vbInformation, "恭喜你"
End
End Sub
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询