设为首页收藏本站Access中国

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步,快速开始

返回列表 发新帖
查看: 646|回复: 2
打印 上一主题 下一主题

[模块/函数] 关于文件重命名的Name——从《万能处方》谈起

[复制链接]
跳转到指定楼层
1#
发表于 2024-5-6 04:48:33 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
刚刚看了帖子《更改照片名称的问题》,楼主说不知道为啥“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. MsgBox "done"
  17. End Sub



  18. Function cleanChars(ByVal strInput As String) As String
  19.     Dim num As Long
  20.     Dim strOutput As String
  21.     Dim strLetter As String
  22.    
  23.     strOutput = ""
  24.     For num = 1 To Len(strInput)
  25.         strLetter = Mid(strInput, num, 1)
  26.         If (Asc(strLetter) >= 48 And Asc(strLetter) <= 57) _
  27.             Or (Asc(strLetter) >= 65 And Asc(strLetter) <= 90) _
  28.             Or (Asc(strLetter) >= 97 And Asc(strLetter) <= 122) Then
  29.          strOutput = strOutput & strLetter
  30.         End If
  31.     Next
  32.     cleanChars = strOutput
  33. End Function
复制代码
附件如下:

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏 分享分享 分享淘帖 订阅订阅

点击这里给我发消息

2#
发表于 2024-5-6 08:18:42 | 只看该作者
先赞一个
只是,你这又是熬夜发贴?
3#
发表于 2024-7-19 10:08:09 | 只看该作者
本帖最后由 ganlinlao 于 2024-7-19 10:23 编辑

@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

您需要登录后才可以回帖 登录 | 注册

本版积分规则

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2024-11-1 07:50 , Processed in 0.070481 second(s), 28 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表