[已解决]批量修改图片名称

dyzx

如果原图片名是中文名称，现要将原名改成身份证号，请问应该怎样修改代码，请各位老师指教，多谢。

最佳答案

月排行榜 / 总排行榜

zjdh

2016-10-12 12:55

有这么个函数就简单啦
Sub Macro1()
     Dim p$, f$, Fso As Object, sFileType$, i&, arr$(), brr$(), m&
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        p = .SelectedItems(1) & "\"
    End With
    sFileType = "*.jpg"
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Call GetFiles(p, sFileType, Fso, arr, m)
    W = Range("A65536").End(3).Row
    If W = 2 Then Exit Sub
    For J = 2 To W
        For i = 1 To m
            If arr(2, i) = Cells(J, 1) & ".jpg" Then
                f = arr(1, i) & Application.Clean(Cells(J, 3).Value) & ".jpg"
                If Dir(f) <> "" Then
                    MsgBox Cells(J, 3) & ".jpg 已存在"
                    GoTo 10
                End If
                Name arr(1, i) & arr(2, i) As f
                Exit For
            End If
        Next
10  Next
    MsgBox "处理完毕", vbInformation
    Set Fso = Nothing
End Sub

跳转到最佳答案楼层

zjdh

新建文件夹.rar (66.2 KB, 下载次数: 13)

2016-10-11 14:45 上传

点击文件名下载附件

dyzx

zjdh 发表于 2016-10-11 14:46

zjdh老师：运行好像有点问题，请指教，多谢。

zjdh

没有问题！
原因是你的新文件名里有问题（我未细细查找），将其设置为“文本”格式，重新输入一次即可正常运行。
批量修改文件名.rar (16.48 KB, 下载次数: 24)

2016-10-11 15:59 上传

点击文件名下载附件

dyzx

zjdh 发表于 2016-10-11 16:00
没有问题！
原因是你的新文件名里有问题（我未细细查找），将其设置为“文本”格式，重新输入一次即可正常 ...

zjdh老师：我按你要求设置为“文本”格式，重新输入一次都有好像有点问题，一直在运行中，请指教。

zjdh

稍作修改，速度可以快点：
Sub Macro1()
    Dim p$, f$, Fso As Object, sFileType$, i&, arr$(), brr$(), m&
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        p = .SelectedItems(1) & "\"
    End With
    sFileType = "*.jpg"
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Call GetFiles(p, sFileType, Fso, arr, m)
    W = Range("A65536").End(3).Row
    If W = 2 Then Exit Sub
    For J = 2 To W
        For i = 1 To m
            If arr(2, i) = Cells(J, 1) & ".jpg" Then
                f = arr(1, i) & Cells(J, 3).Value & ".jpg"
                If Dir(f) <> "" Then
                    MsgBox Cells(J, 1) & ".jpg 已存在"
                    GoTo 10
                End If
                Name arr(1, i) & arr(2, i) As f
                Exit For
            End If
        Next
10  Next
    MsgBox "处理完毕", vbInformation
    Set Fso = Nothing
End Sub

dyzx

zjdh 发表于 2016-10-11 17:30
稍作修改，速度可以快点：
Sub Macro1()
    Dim p$, f$, Fso As Object, sFileType$, i&, arr$(), brr$( ...

zjdh老师：好像仍然不能运行，请指教，多谢。

zjdh

还是你的“身份证”数据问题，任意输入一个内容（文本），即可运行。
2楼的数据都可以运行。

苏子龙

1. Sub tt()
   
2. Dim oldName As String, NewName As String
   
3. Dim phName As String
   
4. Dim d As Object
   
5.     With Application.FileDialog(msoFileDialogFolderPicker) '文件加一定取到你要的那个文件夹里
   
6.         If .Show = False Then Exit Sub
   
7.         phName = .SelectedItems(1) & ""
   
8.     End With
   
9.     arr = Range("a1").CurrentRegion
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     For i = 2 To UBound(arr)
    
12.     '由于身份证有隐藏字符，加clean去除
    
13.         If arr(i, 1) <> "" Then d(arr(i, 1) & ".jpg") = Application.WorksheetFunction.Clean(arr(i, 3))
    
14.     Next
    
15.     On Error Resume Next
    
16.     oldName = Dir(phName)
    
17.     Do While oldName <> ""
    
18.         If d.exists(oldName) Then
    
19.             NewName = d.Item(oldName) & ".jpg"
    
20.             Name phName & oldName As phName & NewName
    
21.         End If
    
22.         oldName = Dir
    
23.     Loop
    
24.     Set d = noting
    
25. End Sub
    

复制代码

dyzx

苏子龙 发表于 2016-10-12 11:04

苏子龙老师：请问“With Application.FileDialog(msoFileDialogFolderPicker) '文件加一定取到你要的那个文件夹里”这句是什么意思？请指教，多谢