批量修改文件名的问题

ailvlv

请教各位老师，在批量修改文件名遇到一个问题，如附件中，需要对A列原文件名做处理生成C列新文件名，处理规则就是将A列原文件名前面的m_去掉，我用替换又不行，因为怕中间会有m_,只需要处理掉前面的m_。
请老师指导一下如何用VBA实现这个功能，谢谢老师了。

zhaogang1960

请测试：

1. Sub Macro1()
   
2.     Dim p$, f$, arr$(), m%, i%
   
3.     p = ThisWorkbook.Path & ""
   
4.     f = Dir(p & "m_*.jpg")
   
5.     Do While f <> ""
   
6.         m = m + 1
   
7.         ReDim Preserve arr(1 To m)
   
8.         arr(m) = f
   
9.         f = Dir()
   
10.     Loop
    
11.     If m = 0 Then
    
12.         MsgBox "没有发现以m_开头的图片文件！", vbInformation
    
13.         Exit Sub
    
14.     End If
    
15.     For i = 1 To m
    
16.         Name p & arr(i) As p & Mid(arr(i), 3)
    
17.     Next
    
18.     MsgBox "处理完毕", vbInformation
    
19. End Sub
    

复制代码

zhaogang1960

请注意，把工作簿放在图片文件夹中，不用输入文件名，程序自动查询以m_开头的图片文件并改名，如果没有发现会提示后退出程序
请看附件
111.rar (20.07 KB, 下载次数: 22)

2013-12-19 23:44 上传

点击文件名下载附件

zhaogang1960

ailvlv 发表于 2013-12-20 16:28
谢谢老师，我刚才测试了一下，发现还是那个问题，解压后，运行批量修改文件名.xls，找到“指定文件夹”下 ...

8楼我已经点评告诉你了：
10楼附件有点问题，已更新
就是Call GetFiles(ThisWorkbook.Path, sFileType, Fso, arr, m)改为
Call GetFiles(p, sFileType, Fso, arr, m)

ailvlv

zhaogang1960 发表于 2013-12-19 23:44
请注意，把工作簿放在图片文件夹中，不用输入文件名，程序自动查询以m_开头的图片文件并改名，如果没有发现 ...

谢谢版主老师指导，就是这个效果，但是有2个扩展细节问题老师能解决吗？
一、程序自动查询以m_开头的图片将m_去掉，如果去掉m_后文件夹里有同名文件，就删除原文件，再改名，也就是覆盖掉原文件的效果。
二、能把只支持图片扩展到支持文件夹内所有文件吗？就是可以指定更改的文件夹，然后把指定文件夹里所有的文件不局限于图片都按照规则修改命名。
请老师指导，谢谢了。

zhaogang1960

ailvlv 发表于 2013-12-20 12:37
谢谢版主老师指导，就是这个效果，但是有2个扩展细节问题老师能解决吗？
一、程序自动查询以m_开头的图片 ...

1. Sub Macro1()
   
2.     Dim f$, Fso As Object, sFileType$, i&, arr$(), brr$(), m&
   
3.     sFileType = "m_*.*"
   
4.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
5.     Call GetFiles(ThisWorkbook.Path, sFileType, Fso, arr, m)
   
6.     If m = 0 Then
   
7.         MsgBox "没有发现以m_开头的文件！", vbInformation
   
8.         Exit Sub
   
9.     End If
   
10.     For i = 1 To m
    
11.         f = arr(1, i) & Mid(arr(2, i), 3)
    
12.         If Dir(f) <> "" Then Kill f
    
13.         Name arr(1, i) & arr(2, i) As f
    
14.     Next
    
15.     MsgBox "处理完毕", vbInformation
    
16.     Set Fso = Nothing
    
17. End Sub
    
18. 
    
19. Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, ByRef Fso As Object, ByRef arr$(), ByRef m&)
    
20.     Dim Folder As Object
    
21.     Dim SubFolder As Object
    
22.     Dim File As Object
    
23.     Set Folder = Fso.GetFolder(sPath)
    
24.     For Each File In Folder.Files
    
25.         If File.Name Like sFileType Then
    
26.             If File.Name <> ThisWorkbook.Name Then
    
27.                 m = m + 1
    
28.                 ReDim Preserve arr(1 To 2, 1 To m)
    
29.                 arr(1, m) = sPath & ""
    
30.                 arr(2, m) = File.Name
    
31.             End If
    
32.         End If
    
33.     Next
    
34.     If Folder.SubFolders.Count > 0 Then
    
35.         For Each SubFolder In Folder.SubFolders
    
36.             Call GetFiles(SubFolder.Path, sFileType, Fso, arr, m)
    
37.         Next
    
38.     End If
    
39.     Set Folder = Nothing
    
40.     Set File = Nothing
    
41.     Set SubFolder = Nothing
    
42. End Sub
    

复制代码

zhaogang1960

请看附件
改名覆盖已存在文件.rar (29.64 KB, 下载次数: 37)

2013-12-20 13:04 上传

点击文件名下载附件

maxiaoan

zhaogang1960 发表于 2013-12-20 13:05
请看附件

老师太牛了，顶一下

ailvlv

zhaogang1960 发表于 2013-12-20 13:05
请看附件

感谢老师您的指导，2个问题都得到解决，但是在指定文件夹这个处理上，我没表达清楚，您现在的程序实现了替换，但是处理的对象是同级目录下所有的文件夹都会处理掉，能不能向我在附件指定文件夹效果那样，先选定文件夹再处理，谢谢老师了。

zhaogang1960

ailvlv 发表于 2013-12-20 15:01
感谢老师您的指导，2个问题都得到解决，但是在指定文件夹这个处理上，我没表达清楚，您现在的程序实现了替 ...

不用分两步：

1. Sub Macro1()
   
2.     Dim p$, f$, Fso As Object, sFileType$, i&, arr$(), brr$(), m&
   
3.     With Application.FileDialog(msoFileDialogFolderPicker)
   
4.         If .Show = False Then Exit Sub
   
5.         p = .SelectedItems(1)
   
6.     End With
   
7.     sFileType = "m_*.*"
   
8.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
9.     Call GetFiles(p, sFileType, Fso, arr, m)
   
10.     If m = 0 Then
    
11.         MsgBox "没有发现以m_开头的文件！", vbInformation
    
12.         Exit Sub
    
13.     End If
    
14.     For i = 1 To m
    
15.         f = arr(1, i) & Mid(arr(2, i), 3)
    
16.         If Dir(f) <> "" Then Kill f
    
17.         Name arr(1, i) & arr(2, i) As f
    
18.     Next
    
19.     MsgBox "处理完毕", vbInformation
    
20.     Set Fso = Nothing
    
21. End Sub
    
22. 
    
23. Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, ByRef Fso As Object, ByRef arr$(), ByRef m&)
    
24.     Dim Folder As Object
    
25.     Dim SubFolder As Object
    
26.     Dim File As Object
    
27.     Set Folder = Fso.GetFolder(sPath)
    
28.     For Each File In Folder.Files
    
29.         If File.Name Like sFileType Then
    
30.             If File.Name <> ThisWorkbook.Name Then
    
31.                 m = m + 1
    
32.                 ReDim Preserve arr(1 To 2, 1 To m)
    
33.                 arr(1, m) = sPath & ""
    
34.                 arr(2, m) = File.Name
    
35.             End If
    
36.         End If
    
37.     Next
    
38.     If Folder.SubFolders.Count > 0 Then
    
39.         For Each SubFolder In Folder.SubFolders
    
40.             Call GetFiles(SubFolder.Path, sFileType, Fso, arr, m)
    
41.         Next
    
42.     End If
    
43.     Set Folder = Nothing
    
44.     Set File = Nothing
    
45.     Set SubFolder = Nothing
    
46. End Sub
    

复制代码