我是VBA的新手(只接受过一点java方面的培训),但是在这里的其他帖子的帮助下组装了这部分代码,并且遇到了困难。
我正在尝试编写代码,这些代码将遍历文件夹中的每个文件,测试每个文件是否满足特定的条件。如果满足条件,则应编辑文件名,覆盖(或先前删除)任何具有相同名称的现有文件。然后,应将这些新重命名的文件的副本复制到其他文件夹。我相信我已经很接近了,但是我的代码在运行时拒绝遍历所有文件和/或使Excel崩溃。请帮帮忙?:-)
Sub RenameImages()
Const FILEPATH As String = _
"C:\\CurrentPath"
Const NEWPATH As String = _
"C:\\AditionalPath"
Dim strfile As String
Dim freplace As String
Dim fprefix As String
Dim fsuffix As String
Dim propfname As String
Dim FileExistsbol As Boolean
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
strfile = Dir(FILEPATH)
Do While (strfile <> "")
Debug.Print strfile
If Mid$(strfile, 4, 1) = "_" Then
fprefix = Left$(strfile, 3)
fsuffix = Right$(strfile, 5)
freplace = "Page"
propfname = FILEPATH & fprefix & freplace & fsuffix
FileExistsbol = FileExists(propfname)
If FileExistsbol Then
Kill propfname
End If
Name FILEPATH & strfile As propfname
'fso.CopyFile(FILEPATH & propfname, NEWPATH & propfname, True)
End If
strfile = Dir(FILEPATH)
Loop
End Sub
如果有帮助,文件名以ABC_mm_dd_hh_Page_#.jpg开头,目标是将它们减少到ABCPage#.jpg
非常感谢!
发布于 2014-11-14 14:14:58
我认为在开始处理它们之前,首先收集数组或集合中的所有文件名是一个好主意,特别是如果您要重命名它们的话。如果不这样做,就不能保证不会混淆Dir(),导致它跳过文件或处理两次“相同”的文件。同样,在VBA中,字符串中不需要转义反斜杠。
下面是一个使用集合的示例:
Sub Tester()
Dim fls, f
Set fls = GetFiles("D:\Analysis\", "*.xls*")
For Each f In fls
Debug.Print f
Next f
End Sub
Function GetFiles(path As String, Optional pattern As String = "") As Collection
Dim rv As New Collection, f
If Right(path, 1) <> "\" Then path = path & "\"
f = Dir(path & pattern)
Do While Len(f) > 0
rv.Add path & f
f = Dir() 'no parameter
Loop
Set GetFiles = rv
End Function
发布于 2014-11-09 16:26:46
编辑:请参阅下面的更新以获取替代解决方案。
您的代码有一个主要问题..Loop
结束之前的最后一行是
...
strfile = Dir(FILEPATH) 'This will always return the same filename
Loop
...
下面是你的代码应该是什么:
...
strfile = Dir() 'This means: get the next file in the same folder
Loop
...
第一次调用Dir()
时,应该指定列出文件的路径,所以在进入循环之前,下面的代码行:
strfile = Dir(FILEPATH)
是好的。该函数将返回与该文件夹中的条件匹配的第一个文件。一旦您完成了对文件的处理,并且希望移动到下一个文件,则应该调用Dir()
,而不指定任何参数来指示您有兴趣迭代到下一个文件。
=======
作为替代解决方案,您可以使用提供给VBA的FileSystemObject
类,而不是由操作系统创建对象。
首先,通过转到工具->参考->Microsoft脚本运行时来添加"Microsoft Scripting Runtime“库
如果您没有看到列出的微软脚本运行时,只需浏览到C:\windows\system32\scrrun.dll
,应该也会这样做。
其次,更改代码以使用被引用的库,如下所示:
以下两行:
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
应替换为以下单行:
Dim fso As New FileSystemObject
现在运行您的代码。如果您仍然面临错误,至少这一次,错误应该有更多关于其来源的详细信息,而不像以前的模糊对象提供的通用错误。
发布于 2014-12-02 07:20:21
如果有人想知道,这里是我完成的代码。感谢Tim和Ahmad的帮助!
Sub RenameImages()
Const FILEPATH As String = "C:\CurrentFilepath\"
Const NEWPATH As String = "C:\NewFilepath\"
Dim strfile As String
Dim freplace As String
Dim fprefix As String
Dim fsuffix As String
Dim propfname As String
Dim fls, f
Set fls = GetFiles(FILEPATH)
For Each f In fls
Debug.Print f
strfile = Dir(f)
If Mid$(strfile, 4, 1) = "_" Then
fprefix = Left$(strfile, 3)
fsuffix = Right$(strfile, 5)
freplace = "Page"
propfname = FILEPATH & fprefix & freplace & fsuffix
FileExistsbol = FileExists(propfname)
If FileExistsbol Then
Kill propfname
End If
Name FILEPATH & strfile As propfname
'fso.CopyFile(FILEPATH & propfname, NEWPATH & propfname, True)
End If
Next f
End Sub
Function GetFiles(path As String, Optional pattern As String = "") As Collection
Dim rv As New Collection, f
If Right(path, 1) <> "\" Then path = path & "\"
f = Dir(path & pattern)
Do While Len(f) > 0
rv.Add path & f
f = Dir() 'no parameter
Loop
Set GetFiles = rv
End Function
Function FileExists(fullFileName As String) As Boolean
If fullFileName = "" Then
FileExists = False
Else
FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
End If
End Function
https://stackoverflow.com/questions/26824225
复制相似问题