Excel·VBA文件重命名

news2024/11/28 22:40:13

获取文件夹下所有文件名

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种代码获取文件名，结果一致
在这里插入图片描述

获取文件夹下所有文件名并重命名

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种代码重命名文件名，结果一致
在这里插入图片描述

简体/繁体文件名重命名

中文简体/繁体互转函数

#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