關(guān)于文件重命名的Name——從《萬能處方》談起

roych

剛剛看了帖子《更改照片名稱的問題》，樓主說不知道為啥“Name X As Y”的方式失效了。
研究了一下，讓我想起了一個很古老的笑話。

病人去做體檢，大夫用他常人難辯的字跡開了張?zhí)幏�，病人把處方揣進袋里，忘了去拿藥。有兩年的時間，他每天早晨把處方當作鐵路通行證出示給檢票員;
還用它進了兩次電影院，一次棒球場和一次交響音樂會;
用它冒充老板的字條得到一次提升。
一天，這個人把處方弄丟了，他的女兒撿到后，在鋼琴上照其演奏，結(jié)果獲得了進公立音樂學院的機會。

應(yīng)該是一個國外笑話，但在電子處方單普及之前，中醫(yī)處方箋也是龍飛鳳舞，不遑多讓的。甚至還有一些奇奇怪怪的寫法，比如，我就見過“茯苓”寫成“服〇”的。
回到笑話本身，本來它只是一個處方單，但到了檢票員那里就成了“鐵路通行證”，到了電影院那里，又成了“電影票”，甚至還成了“老板的字條”。為啥會這樣？一方面有些人對于字跡問題早已熟視無睹，不去深究。
我們回到問題的本身，一般來說，無法重命名，通常有以下幾種情況：

• 找不到文件。
• 文件已經(jīng)被打開。
• 沒有權(quán)限。
• 新文件名有特殊字符。
  

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

果然預(yù)判對了：中間含有不可見字符（黃色部分）。接下來就很容易處理了，只保留數(shù)字和英文字母即可，改完的代碼如下：

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次。重命名后，源文件已經(jīng)不存在，會出現(xiàn)錯誤。這里忽略掉
   
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

復制代碼

附件如下：

tmtony

先贊一個
只是，你這又是熬夜發(fā)貼？

ganlinlao

@Roych 你的name語句代碼應(yīng)該是有瑕疵。
剛好也遇到需要 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
    ' 循環(huán)遍歷文件夾內(nèi)的所有文件
    For Each myFile In fso.GetFolder(folderPath).Files
        ' 獲取文件名
        fileName = myFile.Name
        If InStr(1, fileName, "免費") > 0 Then
            ' 根據(jù)需求修改文件名
            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