指定文件夹的文件检索并复制

Question

这些是想要对指定的文件夹进行搜索，检索到新文件或文件夹就复制到另一个指定文件夹中
但是有个问题就是新生成的文件夹中  过一会儿又有新文件产生要怎么办  就是子目录下又有文件产生了  我也是要复制过去了
想一级一级检索下去  要怎么办呢？？指定的文件夹就一直在变了！大家说用递归   但是如何定义呢？
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Const MAX_PATH = 200
Dim tBrowseInfo As BrowseInfo
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Sub Command1_Click()
With tBrowseInfo
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
Text1.Text = sBuffer
End If
End Sub
Private Sub Command2_Click()
With tBrowseInfo
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
Text2.Text = sBuffer
End If
End Sub
Private Sub Command3_Click()
If Text1.Text = "" Then
MsgBox "请选择源文件夹", 48, "无文件路径"
ElseIf Text2.Text = "" Then
MsgBox "请选择目标文件夹", 48, "无文件路径"
Else
Timer1.Enabled = True
Label3.Caption = "运行中……"
End If
End Sub
Private Sub Command4_Click()
Timer1.Enabled = False
Label3.Caption = "中断"
prosess 0
End Sub
Private Sub Timer1_Timer()Dim limit_time As Data
limit_data = CDate(Now - 1 / 1440) '时间标记，大于这个时间的文件属于新文件
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fsobj
Set fsobj = fso.GetFolder(Text1.Text) '目标文件夹
Dim fsofile
Set fsofile = fsobj.Files
Dim j
For Each j In fsofile
If j.DateCreated > limit_data Then '如果文件的创建时间大于时间标记
FileCopy Text1.Text + "\" + j.Name, Text2.Text + "\" + j.Name '复制文件
End If
Next
Dim fsofolders
Set fsofolders = fsobj.SubFolders
Dim i
For Each i In fsofolders
If i.DateCreated > limit_data Then '如果文件夹的创建时间大于时间标记
fso.copyfolder Text1.Text & "\" & i.Name, Text2.Text & "\" & i.Name '复制文件夹
End If
Next
End Sub

Answer 1

    Private Sub CopyFile(ByVal souFilePath As String, ByVal desFilePath As String) '复制文件包括子文件夹
        On Error Resume Next
        Dim tmpFiles() As String = IO.Directory.GetFiles(souFilePath)
        Dim tmpFolders() As String = IO.Directory.GetDirectories(souFilePath)        Dim i As Integer
        For i = 0 To tmpFiles.Length - 1
            IO.File.Delete(desFilePath & tmpFiles(i).Substring(tmp.Length))
            System.IO.File.Copy(tmpFiles(i), desFilePath & tmpFiles(i).Substring(tmp.Length))
        Next
        For i = 0 To tmpFolders.Length - 1
            System.IO.Directory.CreateDirectory(desFilePath & tmpFolders(i).Substring(tmp.Length))
            CopyFile(tmpFolders(i), desFilePath)
        Next        If Err.Number <> 0 Then
            MessageBox.Show(Err.Description, "错误", MessageBoxButtons.OK, MessageBoxIcon.Error)
        End If
    End Sub

Answer 2

楼上的是什么功能啊？说具体点啊    如果只是复制文件夹的话  不是用shell xcopy不久行了？

Answer 3

如果你的文件只新增不修改，那么不需要判断时间，直接判断是否存在就可以了。
Private Sub SyncFolder(ByVal fso As FileSystemObject, ByVal Source As Folder, ByVal Destination As String)
    Dim fileSrc As file, folderSrc As Folder
    
    For Each fileSrc In Source.Files
        If Not fso.FileExists(Destination & "\" & fileSrc.Name) Then
            fso.CopyFile fileSrc.Path & "\" & fileSrc.Name, Destination & "\" & fileSrc.Name
        End If
    Next    For Each folderSrc In Source.SubFolders
        If Not fso.FolderExists(Destination & "\" & folderSrc.Name) Then
            fso.CopyFolder Source.Path & "\" & folderSrc.Name, Destination & "\" & folderSrc.Name
        Else
            SyncFolder fso, folderSrc, Destination & "\" & folderSrc.Name
        End If
    Next
End SubPrivate Sub Timer1_Timer()
    Dim fso, folderSrc
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folderSrc = fso.GetFolder(Text1.Text)
    SyncFolder fso, folderSrc, Text2.Text
End Sub

Answer 4

楼上的是连子文件夹也判断复制吗？我只要三层根目录就行了饿！
Private Sub Timer1_Timer()Dim limit_time As Data
limit_data = CDate(Now - 1 / 1440) '时间标记，大于这个时间的文件属于新文件
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fsobj
dim z
for z=1 to 3
Set fsobj = fso.GetFolder(Text1.Text) '目标文件夹
Dim fsofile
Set fsofile = fsobj.Files
Dim j
For Each j In fsofile
If j.DateCreated > limit_data Then '如果文件的创建时间大于时间标记
FileCopy Text1.Text + "\" + j.Name, Text2.Text + "\" + j.Name '复制文件
End If
Next
Dim fsofolders
Set fsofolders = fsobj.SubFolders
Dim i
For Each i In fsofolders
If i.DateCreated > limit_data Then '如果文件夹的创建时间大于时间标记
fso.copyfolder Text1.Text & "\" & i.Name, Text2.Text & "\" & i.Name '复制文件夹
End If
text1.text=text1.text+ "\"+ i.name
Next i
next z
End Sub
我是想用循环3次递归，一分钟检索一次。已经复制的就不复制了，免得占内存。但是我不知道我上面的代码有没有什么错的地方。劳烦帮我改正下咯！

Answer 5

不行的，Text1.Text 的修改不能正确进行递归，就用我的代码好了。
最多你再加一个层次参数控制递归的深度好了。

Answer 6

那你上面的Destination和Source就是TEXT？Source=text1.text?
SyncFolder fso, folderSrc, Text2.Text这一句是什么意思？
加个层次参数？
for i=1 to 3
Source=Source& "\" & folderSrc.Name
next 
???
是在TIMER下加?
Set folderSrc = fso.GetFolder(Text1.Text)这句的text要变的啊 

Answer 7

请先掌握基本的语法概念，这没什么好讲的。
按照我的提示，你应该具备将我５楼的代码更改成如下方式的能力，否则……
Private Sub SyncFolder(ByVal fso As FileSystemObject, ByVal Source As Folder, ByVal Destination As String, _
                                ByVal Level As Long)
    Dim fileSrc As file, folderSrc As Folder
    
    For Each fileSrc In Source.Files
        If Not fso.FileExists(Destination & "\" & fileSrc.Name) Then
            fso.CopyFile fileSrc.Path & "\" & fileSrc.Name, Destination & "\" & fileSrc.Name
        End If
    Next    If Level <= 1 Then Exit Sub    For Each folderSrc In Source.SubFolders
        If Not fso.FolderExists(Destination & "\" & folderSrc.Name) Then
            fso.CopyFolder Source.Path & "\" & folderSrc.Name, Destination & "\" & folderSrc.Name
        Else
            SyncFolder fso, folderSrc, Destination & "\" & folderSrc.Name, Level-1
        End If
    Next
End SubPrivate Sub Timer1_Timer()
    Dim fso, folderSrc
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folderSrc = fso.GetFolder(Text1.Text)
    SyncFolder fso, folderSrc, Text2.Text, 3
End Sub