我正在尝试使用该程序复制带有某些字符的文件。要复制的文件应在今天的日期和今天之前的100天之间。我的程序可以运行,但是新文件夹中什么也没有显示。我确实确保文件在这些日期之间。我没有任何错误,所以我不知道在哪里修复。我尝试了其他方法,但没有一个起作用。
我尝试混合使用http://www.rondebruin.nl/win/s3/win026.htm中的代码。我正在玩它,只是copy_folder()
在工作。我收到运行时错误“53” -文件上没有的Copy_Certain_Files_In_Folder()
,并Copy_Files_Dates()
给我什么为好。
无论如何,我的代码有什么问题,如何将并入FileExt
下面的代码?谢谢!
Sub CopyPasteFiles()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim Fdate As Date
Dim FileExt As String
Dim objFile As Object
Dim objFolder As Object
FromPath = "C:\Users\Run" '<< Change
ToPath = "C:\Users\Test" '<< Change
FileExt = "*BT.csv"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
If FSO.FolderExists(ToPath) = False Then
MsgBox ToPath & " doesn't exist"
Exit Sub
End If
For Each objFolder In FSO.GetFolder(FromPath).SubFolders
For Each objFile In objFolder.Files
Fdate = Int(objFile.DateCreated)
If Fdate >= Date And Fdate <= Format(DateAdd("d", -100, Date), "dd mmmm yyyy") Then
objFile.Copy ToPath
End If
Next objFile
Next objFolder
MsgBox "You can find the files from " & FromPath & " in " & ToPath
End Sub
好的,我尝试添加一些注释以给您一些指导。您遇到的第一个问题是,您没有对根文件夹执行任何操作-您试图直接进入子文件夹,这可能就是您说它“突出显示”外循环层上的行的原因。(突出显示的行是当您下次按下F8键时将执行的行。)
我所做的就是将复制操作分成另一个过程,因此您可以在任何子文件夹上递归调用它。这只是一种方法-还有其他可能更简单的方法,但这是我想到的,因为我习惯于以这种方式递归地挖掘文件夹和记录集。
您遇到的另一个问题是比较日期的方法。.DateCreated
属性的格式带有日期和时间。您可以直接将Now()
其与返回日期和时间的Date()
函数进行比较-但是,如果您尝试与该函数进行比较,则该函数将不起作用,因为它是一种不同的格式。
我不确定您要使用文件扩展名做什么。我假设您想将其用作过滤器,所以这就是我所做的。
一些注意事项:您当前正在最后告诉用户“您可以从中找到文件”,但您没有检查这是否正确。您可能想要在.Copy
操作后添加检查,然后将结果添加到数组或其他内容中,以便向用户显示成功复制的文件和未复制的文件的列表。在测试时,我创建了Users
目录中的文件夹,尝试复制没有所需权限的文件夹时出现错误。
现在,“开始”路径,“到”路径和扩展名过滤器均已进行硬编码。如果您打算分发此文件或将自己在多个位置使用它,则可以使用BrowseForFolder方法向用户显示文件夹浏览器对话框,并允许他们选择“从”和“到”文件夹。您还可以使用InputBox
从用户那里获得过滤器。只是一个想法。
无论如何,这是我对您的代码所做的。我将变量名更改为我的命名约定,仅仅是因为这就是我的习惯-您可以根据需要更改它们。
Option Explicit
Public Sub CopyPasteFiles()
'Declare variables
Dim SRfso As Scripting.FileSystemObject
Dim strFrom As String
Dim strTO As String
Dim strExtFilter As String
Dim SRfolderA As Scripting.Folder
Dim SRfolderB As Scripting.Folder
'Are you always going to hardcode these or do you want to be able to browse for a folder?
strFrom = "C:\Users\Run" '<< Change
strTO = "C:\Users\Test" '<< Change
'I'm not sure what your intent is with this - I assumed you wanted to filter by file extension.
strExtFilter = "*BT.CSV"
'Prep the folder path
If Right(strFrom, 1) <> "\" Then
strFrom = strFrom & "\"
End If
'Intialize the FileSystemObject
Set SRfso = New Scripting.FileSystemObject
'Verify input and output folders exist. Inform user if they don't.
If SRfso.FolderExists(strFrom) = False Then
MsgBox strFrom & " doesn't exist"
Exit Sub
End If
If SRfso.FolderExists(strTO) = False Then
MsgBox strTO & " doesn't exist"
Exit Sub
End If
'Get the input folder using the FileSystemObject
Set SRfolderA = SRfso.GetFolder(strFrom)
'Call the routine that copies the files
MoveTheFiles SRfolderIN:=SRfolderA, strFolderOUT:=strTO ', strExtFilter:=strExtFilter
'Inform the user where they can find the files. CAUTION: You may be misinforming the user.
MsgBox "You can find the files from " & strFrom & " in " & strTO
End Sub
Private Sub MoveTheFiles(ByRef SRfolderIN As Scripting.Folder, _
ByRef strFolderOUT As String, _
Optional ByRef strExtFilter As String = "*.*", _
Optional ByRef blnSUBFOLDERS As Boolean = True)
'This routine copies the files. It requires two arguments. First, it requires the root folder as folder object from the scripting library. _
Second, it requires the output path as a string. There are two optional arguments. The first allows you _
to use a text filter as a string. The second is a boolean that tells us whether or not to move files in subfolders - the default is true.
'Delcare variables
Dim SRfileA As Scripting.File
Dim SRfolderCol As Scripting.Folders
Dim SRfolderA As Scripting.Folder
Dim datCreated As Date
Dim lngFX As Long
Dim blnResult As Boolean
'Find the file extension in the filter
lngFX = InStrRev(strExtFilter, ".", , vbTextCompare)
'Move the files from the root folder
For Each SRfileA In SRfolderIN.Files
'Only work with files that contain the filter criteria
If Ucase(Mid(SRfileA.Name, InStrRev(SRfileA.Name, ".", , vbTextCompare) - (Len(strExtFilter) - lngFX) + 1, Len(strExtFilter))) Like Ucase(strExtFilter) Then
'Only work with files that were created within the last 100 days
datCreated = SRfileA.DateCreated
If datCreated <= Now And (datCreated >= DateAdd("d", -100, Now())) Then
SRfileA.Copy strFolderOUT
End If
End If
Next
'Check if the calling procedure indicated we are supposed to move subfolder files as well
If blnSUBFOLDERS Then
'Check that we have subfolders to work with
Set SRfolderCol = SRfolderIN.SubFolders
If SRfolderCol.Count > 0 Then
For Each SRfolderA In SRfolderIN.SubFolders
MoveTheFiles SRfolderIN:=SRfolderA, strFolderOUT:=strFolderOUT, strExtFilter:=strExtFilter, blnSUBFOLDERS:=blnSUBFOLDERS
Next
End If
End If
End Sub
本文收集自互联网,转载请注明来源。
如有侵权,请联系[email protected] 删除。
我来说两句