关于文件重命名的Name——从《万能处方》谈起

roych

刚刚看了帖子《更改照片名称的问题》，楼主说不知道为啥“Name X As Y”的方式失效了。
研究了一下，让我想起了一个很古老的笑话。

病人去做体检，大夫用他常人难辩的字迹开了张处方，病人把处方揣进袋里，忘了去拿药。有两年的时间，他每天早晨把处方当作铁路通行证出示给检票员;
还用它进了两次电影院，一次棒球场和一次交响音乐会;
用它冒充老板的字条得到一次提升。
一天，这个人把处方弄丢了，他的女儿捡到后，在钢琴上照其演奏，结果获得了进公立音乐学院的机会。

应该是一个国外笑话，但在电子处方单普及之前，中医处方笺也是龙飞凤舞，不遑多让的。甚至还有一些奇奇怪怪的写法，比如，我就见过“茯苓”写成“服〇”的。
回到笑话本身，本来它只是一个处方单，但到了检票员那里就成了“铁路通行证”，到了电影院那里，又成了“电影票”，甚至还成了“老板的字条”。为啥会这样？一方面有些人对于字迹问题早已熟视无睹，不去深究。
我们回到问题的本身，一般来说，无法重命名，通常有以下几种情况：

• 找不到文件。
• 文件已经被打开。
• 没有权限。
• 新文件名有特殊字符。
  

前面3个很容易就排除了。所以极有可能是第4个。于是，我们print一下看看：

果然预判对了：中间含有不可见字符（黄色部分）。接下来就很容易处理了，只保留数字和英文字母即可，改完的代码如下：

1. Private Sub 查找相片_Click()
   
2.     Dim j As Integer
   
3.     Dim js As Long
   
4.     Dim rs As ADODB.Recordset
   
5.     Set rs = New ADODB.Recordset
   
6.     rs.Open "表1", CurrentProject.Connection, adOpenKeyset, adLockPessimistic
   
7.     js = rs.RecordCount
   
8.     On Error Resume Next '只重命名1次。重命名后，源文件已经不存在，会出现错误。这里忽略掉
   
9.     For j = 1 To js
   
10.         Name CurrentProject.Path & "" & rs(1) & ".jpg" As CurrentProject.Path & "" & cleanChars(rs(2)) & ".jpg"
    
11.         rs.MoveNext
    
12.     Next j
    
13.    
    
14. rs.Close
    
15. Set rs = Nothing
    
16. 
    
17. MsgBox "done"
    
18. End Sub
    
19. 
    
20. 
    
21. 
    
22. Function cleanChars(ByVal strInput As String) As String
    
23.     Dim num As Long
    
24.     Dim strOutput As String
    
25.     Dim strLetter As String
    
26.    
    
27.     strOutput = ""
    
28.     For num = 1 To Len(strInput)
    
29.         strLetter = Mid(strInput, num, 1)
    
30.         If (Asc(strLetter) >= 48 And Asc(strLetter) <= 57) _
    
31.             Or (Asc(strLetter) >= 65 And Asc(strLetter) <= 90) _
    
32.             Or (Asc(strLetter) >= 97 And Asc(strLetter) <= 122) Then
    
33.          strOutput = strOutput & strLetter
    
34.         End If
    
35.     Next
    
36.     cleanChars = strOutput
    
37. End Function

复制代码

附件如下：

ganlinlao

@Roych 你的name语句代码应该是有瑕疵。
刚好也遇到需要 vba代码 批量修改文件名。
递归无限级子文件夹，批量替换文件名。
Sub main()
    RenameFiles Application.ActiveDocument.Path
End Sub

Sub RenameFiles(folderPath As String)
    '引用 microsoft scripting runtime
    Dim fso As New Scripting.FileSystemObject, myfolder As Folder, subFolder As Folder
    Dim myFile As File, fileName As String, newName As String
    ' 循环遍历文件夹内的所有文件
    For Each myFile In fso.GetFolder(folderPath).Files
        ' 获取文件名
        fileName = myFile.Name
        If InStr(1, fileName, "免费") > 0 Then
            ' 根据需求修改文件名
            newName = Replace(fileName, "【学习资源库】免费分享", "")
            ' 修改文件名
            Name folderPath & "\" & fileName As folderPath & "\" & newName
            '不喜欢用Name语句，用下一行代码也可以。
            'myFile.Name = newName
        End If
    Next myFile
    '递归子文件夹，批量处理
    For Each subFolder In fso.GetFolder(folderPath).subfolders
        RenameFiles subFolder.Path
    Next
    ' 释放对象
    Set fso = Nothing
End Sub

tmtony

先赞一个
只是，你这又是熬夜发贴？