1，获取文件夹下所有文件名
Sub 测试代码()
Dim i&, j&
file_path = "E:\测试\重命名"
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(file_path).Files '遍历文件夹里文件
i = i + 1: Cells(i, 1).Value = f.Name
Next
End With
file_name = Dir(file_path & "\*")
Do While file_name <> ""
j = j + 1: Cells(j, 3).Value = file_name
file_name = Dir
Loop
End Sub
2种代码获取文件名，结果一致
2，获取文件夹下所有文件名并重命名
Dim fso As Object, file_path$, gfd, f '公共变量
Sub 获取文件夹下所有文件名()
file_path = "E:\测试\重命名" '指定文件夹
Range("A:B").ClearContents '仅清空数据
[a1].Resize(1, 2) = Array("原文件名", "新文件名"): i = 1
Set fso = CreateObject("Scripting.FileSystemObject") '文件访问对象
Set gfd = fso.GetFolder(file_path) '获取文件夹对象
For Each f In gfd.Files
i = i + 1: Cells(i, 1).Value = f.Name
Next
Debug.Print "获取文件夹下所有文件名，已完成"
End Sub
Sub 对获取的文件重命名()
'注意避免新旧文件名有重复的，否则可能报错
If [a2] = "" Then Debug.Print "请先执行第一步": Exit Sub
i = 1
For Each f In gfd.Files '遍历文件夹里的所有文件
i = i + 1: f.Name = Cells(i, 2).Value '将原文件名改成B列对应的新文件名
Next
Debug.Print "文件重命名，已完成"
End Sub
Sub 文件重命名()
'对固定文件夹中文件重命名，适用以上sub获取的文件名（只要文件存在即可）
Dim arr, i&, file_path$, olddir$, newdir$
arr = [a1].CurrentRegion.Value
file_path = "E:\测试\重命名" '指定文件夹
For i = 2 To UBound(arr)
olddir = file_path & "\" & arr(i, 1)
newdir = file_path & "\" & arr(i, 2)
Name olddir As newdir
Next
Debug.Print "文件重命名，已完成"
End Sub
2种代码重命名文件名，结果一致
3，按顺序重命名
对文件夹下文件按顺序重命名
3.1，重命名为序号
Sub 文件名批量重命名顺序序号()
'批量重命名文件夹中文件的文件名，按顺序序号重命名
Dim length&, file_path$, file_name$, c&, fso As Object
length = 4 '序号位数，即序号最少位数
file_path = "E:\测试\重命名" '待重命名文件所在的文件夹
file_name = Dir(file_path & "\*") '*后可指定文件扩展名
str_0 = WorksheetFunction.Rept("0", length) 'length位0的字符串
Set fso = CreateObject("Scripting.FileSystemObject")
Do While file_name <> ""
c = c + 1
olddir = file_path & "\" & file_name
newdir = file_path & "\" & Format(c, str_0) & "." & fso.GetExtensionName(file_name)
If olddir <> newdir Then Name olddir As newdir
file_name = Dir '下一个文件名
Loop
Debug.Print "该文件夹下所有文件重命名处理完成：" & file_path
End Sub
3.2，文件名前添加序号
Sub 文件名前批量添加序号()
'批量重命名文件夹中文件的文件名，按顺序在文件名前添加固定位数序号
Dim length&, delimiter$, file_path$, file_name$, c&
length = 4 '序号位数，即添加的序号最少位数
delimiter = "_" '分隔符，序号与原文件名之间，也可以为空
file_path = "E:\测试\重命名" '待重命名文件所在的文件夹
file_name = Dir(file_path & "\*") '*后可指定文件扩展名
str_0 = WorksheetFunction.Rept("0", length) 'length位0的字符串
Do While file_name <> ""
c = c + 1
olddir = file_path & "\" & file_name
newdir = file_path & "\" & Format(c, str_0) & delimiter & file_name
Name olddir As newdir
file_name = Dir '下一个文件名
Loop
Debug.Print "该文件夹下所有文件重命名处理完成：" & file_path
End Sub
4，简体/繁体文件名重命名
中文简体/繁体互转函数
#If Win64 Then
Private Declare PtrSafe Function LCMapString Lib "kernel32" Alias "LCMapStringA" (ByVal Locale As Long, ByVal dwMapFlags As Long, ByVal lpSrcStr As String, ByVal cchSrc As Long, ByVal lpDestStr As String, ByVal cchDest As Long) As Long
Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
#ElseIf Win32 Then
Private Declare Function LCMapString Lib "kernel32" Alias "LCMapStringA" (ByVal Locale As Long, ByVal dwMapFlags As Long, ByVal lpSrcStr As String, ByVal cchSrc As Long, ByVal lpDestStr As String, ByVal cchDest As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
#End If
Function chs2cht(ByVal str As String) As String
'简体转繁体
Dim str_len&, cht$
str_len = lstrlen(str) '指定字符串的长度
cht = Space(str_len) '相同长度的空字符串
LCMapString &H804, &H4000000, str, str_len, cht, str_len
chs2cht = cht
End Function
Function cht2chs(ByVal str As String) As String
'繁体转简体，有一些繁体字无法转换
Dim str_len&, chs$
str_len = lstrlen(str) '指定字符串的长度
chs = Space(str_len) '相同长度的空字符串
LCMapString &H804, &H2000000, str, str_len, chs, str_len
cht2chs = chs
End Function
文件夹下所有文件名繁体转简体
Sub 文件夹下所有文件名繁体转简体()
Dim file_path$, file_name$
file_path = "E:\测试\重命名" '待重命名文件所在的文件夹
file_name = Dir(file_path & "\*") '*后可指定文件扩展名
Do While file_name <> ""
olddir = file_path & "\" & file_name
newdir = file_path & "\" & cht2chs(file_name)
Name olddir As newdir
file_name = Dir '下一个文件名
Loop
Debug.Print "该文件夹下所有文件重命名处理完成：" & file_path
End Sub
转换效果一般，部分繁体字无法转换
5，批量移动文件
批量移动指定文件夹下文件至目标文件夹
Sub 文件夹下文件移动至指定文件夹()
'仅移动文件，不移动子文件夹；old_path、new_path必须以\结尾
Dim old_path$, new_path$, ext$, f
old_path = "E:\测试\重命名\1\"
new_path = "E:\测试\重命名\2\"
ext = "xls*" '仅移动指定扩展名，可使用通配符，*为所有文件
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(old_path) Then Debug.Print "文件夹不存在": Exit Sub
If Not .FolderExists(new_path) Then .CreateFolder (new_path)
For Each f In .GetFolder(old_path).Files '遍历文件夹里文件
If .GetExtensionName(f.Name) Like ext Then
If Not .FileExists(new_path & f.Name) Then '文件不存在
'.movefile old_path & f.Name, new_path '2种移动等价
f.Move (new_path)
Else
Debug.Print "移动失败，目标文件夹已存在该文件：" & f.Name
End If
End If
Next
End With
Debug.Print "文件夹所有文件移动完成"
End Sub
6，批量创建文件夹
如果待创建的文件夹名称包含非法字符，即
\/:*?"<>|
则无法创建，可参考《Excel·VBA按列拆分工作表、工作簿》调用RE_STR函数清除
Sub 批量创建文件夹()
'在指定文件夹下创建多个指定名称的文件夹，文件夹已存在2种方法都会报错
Dim file_path$, name_path, temp$, n
file_path = "E:\测试\重命名\" '待创建文件夹所在的文件夹
'name_path = Array("高举", "李丝雅", "梁存厚", "黄秉坤", "吴明晋", "林铭", "李洛由", "高舜钦", "吕易忠", "常青云")
name_path = [a1].CurrentRegion.Value '从表格读取数据，单行单列多行多列都可
'--------------------mkdir实现方法
' For Each n In name_path
' If Len(n) Then MkDir (file_path & "\" & n)
' Next
'--------------------fso实现方法，加入判断文件夹是否存在
With CreateObject("Scripting.FileSystemObject")
For Each n In name_path
If Len(n) Then
temp = file_path & "\" & n
If Not .FolderExists(temp) Then .CreateFolder (temp)
End If
Next
End With
Debug.Print "文件夹创建完成"
End Sub
|
