VBA 对文件夹内的图片名称重新命名

rendiule01

求助各位老师，想给货品图片文件夹（D:\Attachments）内的图片名称修改。

子文件夹内有1张或2张或3张图片数量不同，现想对其图片名称修改为 子文件名称的数字编号部分
1.当图片格式相同时，第一张为文件名称的数字编号部分，第二张为文件名称的数字编号部分-1，第三张文件名称的数字编号部分-2，依次递增编号
2.当图片格式不相同时，名称都是文件名称的数字编号部分
具体如下图片

Attachments.zip (1.64 MB, 下载次数: 22)

2022-10-8 12:47 上传

点击文件名下载附件

rendiule01

我顶，没有大佬出手吗？

perfect131

vbs 或 bat 即可

rendiule01

perfect131 发表于 2022-10-8 15:01
vbs 或 bat 即可

求具体操作

盼盼198310

..................

rendiule01

盼盼198310 发表于 2022-10-8 18:19
..................

谢谢大佬，非常接近我想要的结果，再一次遍历子文件 把应该可以把尾部是-0 的货品图片名称去除，就是我想要的结果！
   因为我的ACCESS 图片控件 根据子文件名称，显示对应的图片

半百

Sub test()
Set d = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("scripting.filesystemobject")
For Each ff In fso.getfolder(ThisWorkbook.Path).subfolders
    d.RemoveAll: s = ""
    For Each f In fso.getfolder(ff).Files
        s = Split(f, ".")(1)
        If d.EXISTS(s) Then
            d(s) = d(s) + 1
            ss = "-" & d(s)
        Else
            d(s) = 0
        End If
        Name f As ff.Path & "/" & Split(ff.Name, "-")(1) & ss & "." & s
    Next
Next
End Sub

rendiule01

Sub CommandButton1_Click()
    On Error Resume Next
    Dim FSO对象 As Object
    Dim Sh As Object
    Dim Folder As Object
    Dim 文件夹 As Object
    Dim 子文件夹集合 As Object
    Dim 子文件夹 As Object
    Dim 当前文件夹 As Object
    Dim strPath As String
    Dim i As Object
    Dim j As Integer
    Dim brr()

    Set Sh = CreateObject("shell.application")
    Set Folder = Sh.BrowseForFolder(0, "选择货品图片：Attachments 文件夹路径", 0, "Attachments")
    If Not Folder Is Nothing Then
        strPath = Folder.Items.Item.Path
    End If

    If Len(strPath) = 0 Then
        MsgBox "请重新选择货品图片的路径！", vbExclamation + vbOKOnly, "Aryou提示"
        Set Sh = Nothing
        Set Folder = Nothing
        Exit Sub
    End If

    Set FSO对象 = CreateObject("Scripting.FileSystemobject")
    Set 文件夹 = FSO对象.GetFolder(strPath)
    Set 子文件夹集合 = 文件夹.SubFolders
    For Each 子文件夹 In 子文件夹集合

        Set 当前文件夹 = FSO对象.GetFolder(strPath & "\" & 子文件夹.Name)

        For Each i In 当前文件夹.Files '子文件名称重命名，会报错已存在
            i.Name = Mid(子文件夹.Name, InStr(子文件夹.Name, "-") + 1) & "-" & j & "." & FSO对象.GetExtensionName(i)
            j = j + 1
        Next

        j = 0

        brr = 当前文件夹.Files.Name '装入数组

        '        Dim y As Integer
        '        y = 0
        '        For Each i In 当前文件夹.Files
        '            brr(y) = i.Name '子文件夹的文件名称装入数组
        '            y = y + 1
        '        Next
        '        y = 0

        For Each i In 当前文件夹.Files  
            If i.Name = brr(LBound(brr)) Then '把子文件夹内第一个文件名称更改为子文件名称编号部分
                i.Name = Mid(子文件夹.Name, InStr(子文件夹.Name, "-") + 1) & "." & FSO对象.GetExtensionName(i)
            End If
        Next

        Erase brr '清空数组

    Next

    Set FSO对象 = Nothing
    Set 文件夹 = Nothing
    Set 子文件夹集合 = Nothing
    Set 子文件夹 = Nothing
    Set 当前文件夹 = Nothing
    Set i = Nothing
    Set Sh = Nothing
    Set Folder = Nothing
    MsgBox "货品图片的名称修改成功！", vbExclamation + vbOKOnly, "Aryou提示"
End Sub

rendiule01

盼盼198310 发表于 2022-10-8 18:19
..................

老师，为何文件名有特殊字符（.）就修改不来啊？ Attachments - 副本.zip (1.25 MB, 下载次数: 8)

2022-11-28 16:12 上传

点击文件名下载附件

wanghan519

系统自带的powershell，目前最强力的批量改名工具（吹个牛）
不存在特殊字符的问题

1. Get-ChildItem -Directory | % {$n=($_.Name -split '-')[-1];$h=@{};Get-ChildItem -Path $_ | Rename-Item -NewName {$n+"-"+($h[$_.Extension]++)+$_.Extension}}
   
2. Get-ChildItem *-0.* -Recurse | Rename-Item -NewName {$_.Name -replace '-0',''}

复制代码

一共两句：
1. 列出所有目录，对每个目录把数字存入$n，新建一个字典$h，遍历当前目录下的文件，以扩展名为key创建字典项目，将文件改名为($n+字典值+扩展名)，最后value自加1
2. 递归遍历所有含有-0的文件，改名去掉所有'-0'