文/黄波艺
前段时间小丫头班级组织校外活动，给小朋友们照了不少照片。回家导出相片后准备分类整理一下发给小伙伴们。然后发现了一个问题：相片的命名都是以相机的默认方式进行命名的-“IMG******”。但是为了方便管理和分发，我需要把文件名改为“王小丫1”，“王小丫2”，“李小胖1”，“李小胖2”这种类型…我总不能一张张地改吧，好几百张呢。
碰到这种要重复工作的事情，我坚信一定有更高效的解决办法。没错，VBA能干这活。
先上效果图
如果对代码没有兴趣，只想用用这个小工具的话，可以直接跳到文章末尾通过链接下载。
运行效果图
思路与代码
1.设计窗体
窗体
2. 获取用户需要修改的图片的完整文件名（包括路径），存放于数组--用getOpenFile函数；
、、、
‘将arr_Choose定义为全局变量
Dim arr_Choose
PrivateSub cmd_choose_Click()
'获取文件路径以及文件名
‘如果用户在选择文件窗口点击了“取消”，则直接跳到最后。
On
Error GoTo endd lbl_info.Caption = "共选择了0个项目"
arr_Choose
= Application.GetOpenFilename("所有文件,*.*",1, , , True)
lbl_info.Caption
= "共选择了" & UBound(arr_Choose) & "个项目"
Textbox.Value= ""
Textbox.Enabled= True
endd:
End Sub
3.通过TextBox获取用户自定义文件名；
4.修改文件名--用Name…As…语句；
Private Sub cmd_ok_Click()
Dim arr
Dim str_newName As String
Dim str_nameType As String
Dim str_Url As String
Dim i, j As Integer
str_newName = Textbox.Value
If str_newName <>
"" And str_newName <> "请先选择需要批量重命名的文件"Then
'获取文件后缀
str_nameType = Split(arr_Choose(1),".")(1)
'获取文件绝对路径
arr = Split(arr_Choose(1), "\")
For i = LBound(arr) To UBound(arr) - 1
str_Url = str_Url & arr(i) &"\"
Next
On Error GoTo x
'对所选文件循环进行重命名
For j = LBound(arr_Choose) ToUBound(arr_Choose)
Name arr_Choose(j) As str_Url &str_newName & j & "." & str_nameType
Next
MsgBox "你已完成文件重命名。"
x:
lbl_info.Caption = "共选择了0个项目"
Textbox.Value = "请先选择需要批量重命名的文件"
Textbox.Enabled = False
End If
End Sub
、、、
5.完善细节，比如提示选择用户已选择几个文件，限制非法字符输入，提醒用户已完成文件重命名等。
、、、
‘Excel文件打开时隐藏主程序，同时运行窗体。
PrivateSub Workbook_Open()
Application.Visible = False
UserForm1.Show
End Sub
‘TextBox字符输入限制
PrivateSub Textbox_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
SelectCase KeyAscii
Case Asc("/"),Asc("\"), Asc(":"), Asc("*"), Asc("?"),Asc("<"), Asc(">"), Asc("|")
MsgBox "请勿输入非法字符：""/\ : * ? <> |""",vbInformation, "提醒"
KeyAscii = 0
EndSelect
EndSub
‘用户退出，关闭窗体时，Excel主程序恢复可见，以及关闭此程序所在的工作簿。
PrivateSub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.Visible = True
If Application.Windows.Count = 1 Then
Application.Quit
Else
Application.Windows(Application.Windows.Count).Close
End If
End Sub
、、、
思考
VBA还有一个函数叫Dir，它有能力历遍指定的文件夹下指定类型的文件。但是，它返回的只是文件名而不带完整的路径。所以如果要在这里应用不合适，有一定局限性。如果我自己用的话，我自己每次在代码里指定路径就行了，代码也简单。但是要给不懂VBA的用户用，那显然是不合适的。
干脆把Dir代码也贴出来，有兴趣的朋友可以看看。
Option Explicit
Sub Rename()
Dim str_Name As String
Dim i As Long
str_Name =Dir("D:\photos\*.*")
For i = 1 To 99999
Name "D:\photos\" & str_NameAs "D:\photos\MM" & i & "." & Split(str_Name,".")(1)
str_Name = Dir
If str_Name = "" Then
Exit For
End If
Next
MsgBox "已完成文件重命名。"
End Sub
最后
批量修改文件名的文件已经上传到百度云盘。有兴趣的朋友可以通过以下链接下载：
链接：http://pan.baidu.com/s/1eRIvNCQ密码：f3or
如果有朋友想动手试试自己修改里面的代码，可以先禁用宏，然后打开文件进入VBE查看。
