[VBA接力赛第2期]批量更改文件名[已总结]

lpz001 · 发表于 2007-3-28 20:45

-------------------------------- Yxrj --------------------------------'下面制作路径选择对话框的代码，也用到API函数'从别处借来的，还不太明白，添加不了注释'#####################################Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As FolderInfor) As LongDeclare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

rivate Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

rivate Declare Function EnableWindow Lib "user32" (ByVal hWnd As Long, ByVal fEnable As Long) As Long

ublic Type FolderInfor    hOwner As Long    pidlRoot As Long    pszDisplayName As String    lpszTitle As String    ulFlags As Long    lpfn As Long    lParam As Long    iImage As LongEnd Type-------------------------------------------------------------------------------------------------------Sub BrowDir()    Dim iFolder As FolderInfor    Dim pidl As Long, Flag As Long, iPath As String, Pos As Integer, myPath As String    EnableWindow FindWindow("XLMAIN", Application.Caption), False    pidl& = SHBrowseForFolder(iFolder)    EnableWindow FindWindow("XLMAIN", Application.Caption), True    iPath = Space$(512)    Flag = SHGetPathFromIDList(ByVal pidl, ByVal iPath)    If Flag Then

os = InStr(iPath, Chr$(0))        myPath = Left(iPath, Pos - 1)    End If    sSelPath = myPathEnd Sub '############################################'下面是在给定目录及其子目录下查找文件的自定义函数代码，用到API函数。'从网上搜来的，还不太明白，所以添加不了注释 '###################################

ublic Declare Function SearchTreeForFile Lib "imagehlp.dll" (ByVal lpRoothPath As String, ByVal lpInputName As String, _ByVal lpOutputName As String) As Long  '---- 下面为sysFileFind函数的编码：

ublic Function sysFileFind(ByVal WhichRootPath As String, ByVal WhichFileName As String) As StringDim iNull As IntegerDim lResult As LongDim sBuffer As String    On Error GoTo L_FILEFINDERROR    sBuffer = String$(1024, 0)'注释:     查找文件lResult = SearchTreeForFile(WhichRootPath, WhichFileName, sBuffer)   ' 注释：如果文件找到，将返回字符串后续的空格删除'注释:     否则返回一个空字符串    If lResult Then        iNull = InStr(sBuffer, vbNullChar)        If Not iNull Then            sBuffer = Left$(sBuffer, iNull - 1)        End If        sysFileFind = sBuffer        Else            sysFileFind = ""    End IfExit FunctionL_FILEFINDERROR:MsgBox "查找文件过程中遇到错误！", vbInformation, "查找文件错误"sysFileFind = Format(Err.Number) & " - " & Err.DescriptionEnd Function------------------------------------------------------------------------------------------------------------------

ublic sSelPath As String, i%  'sSelPath存储路径选择对话框的值，i存储要更名的文件序号（文件名） Sub <place wst="on">Main</place>()    Dim sFileFindVal As String, iMsg%  'sFileFindVal存放查找文件函数返回的值    i = 1    MsgBox "请单击确定，选择文件所在的目录", 64 + vbOKOnly, "提示"    Do        BrowDir   '启动路径选择对话框                '下面if判断如果没有选择或取消则退出本次更名        If Len(sSelPath) = 0 Then            MsgBox "你没有选择路径，将要退出本次更名", 64 + vbOKOnly, "提示"            Exit Do        End If        MsgBox "你选择的路径是" & sSelPath & Chr(10) & "单击确定将在这个目录及子目录下搜索", 64 + vbOKOnly, "提示"                '下面的循环体是更改文件名的主要部分        Do            sFileFindVal = sysFileFind(sSelPath, i & ".xls")  '调用查找文件函数查找文件，并把值赋给sFileFindVal            '下面if部分给出最后更改的文件名并提示是否继续，如果继续，被查找的文件名仍在原来的基础上递增            If Len(sFileFindVal) = 0 Then                iMsg = MsgBox(i & ".xls文件没有找到" & Chr(10) & "本次更名共有" & i - 1 & "个文件被改名" _                & Chr(10) & "是否继续在其他目录里查找？", 64 + vbYesNo, "提示")                Exit Do  '退出此循环体            End If            ReName (sFileFindVal)  '调用改名函数进行改名            i = i + 1        <place wst="on">Loop</place>            Loop While iMsg = 6    End Sub '更名函数代码Function ReName(FileFullName As String)    Dim Thispath As String, sTemName As String    Thispath = ThisWorkbook.Path             '取得此文件的路径    Dim myObj As Object        Set myObj = GetObject(FileFullName) 'GetObject返回工作薄对象的引用    sTemName = sNewName(myObj.Sheets(1).Cells(1, 1).Value)   '取得单元格a1的值    myObj.Close  '关闭工作博    FileCopy FileFullName, Thispath & "\" & sTemName & ".xls"   '复制文件到本工作博所在目录下并改名    Kill FileFullName  '删除原来的文件        Set myObj = NothingEnd Function '判断文件名的合法性函数代码Function sNewName(sRanVal As String)    Dim sFeiFa() As String, j%, iMsg%, sTem$    sFeiFa = <city wst="on"><place wst="on">Split</place></city>("/,\,|,:,"",?,*,<,>", ",")  '将不能在文件名中出现的字符存入数组    sTem = sRanVal    '下面循环体判断a1的值中是否含有非法字符，若有就给出两种选择：只去除非法字符或手动命名    For j = 0 To 8        If InStr(1, sTem, sFeiFa(j)) = 0 Then            sNewName = sTem        Else            iMsg = MsgBox(i & ".xls中A1含有非法字符 " & sFeiFa(j) & Chr(10) & "去除非法字符命名单击“是”,重新输入文件名请单击“否”", 64 + vbYesNo, "提示")            If iMsg = 6 Then                sTem = Replace(sTem, sFeiFa(j), "")            Else                sTem = InputBox("请输入文件名", "重新命名")            End If        End If    Next    '下面if部分判断是否有重文件，若有，给出两种选择：覆盖、重新命名    If Len(sysFileFind(ThisWorkbook.Path, sTem & ".xls")) <> 0 Then        iMsg = MsgBox("文件名重复，是否覆盖？", 64 + vbYesNo, "提示")        If iMsg = 7 Then sTem = InputBox("请输入文件名", "重新命名")    End If    '下面循环体判断文件名是否为空，若空，则要求手工输入    Do While Len(sTem) = 0        sTem = InputBox("文件名不能为空，请输入", "重新命名")    <place wst="on">Loop</place>    sNewName = sTemEnd Function  Yxrj:  我能看懂的不多，利用自制路径选择对话框选择更名文件夹（使用方便），使用FileCopy和Kill方法实现更名。对重命名，给出了覆盖和手工命名两种选择。对空的命名则要求手工输入。利用循环判断，对无效字符提供了去除及手工命名两种选择。细节注意的比较多，但对原文件名有限制，必须是从1开始连续的数字文件名，并且文件从原文件夹保存至ThisworkBook路径下，未给出提示。[em04]

lpz001 · 发表于 2007-3-28 20:47

--------------------------------雨霖铃--------------------------------Sub yxjline()Application.ScreenUpdating = FalseSet fs = Application.FileSearchWith fs    .LookIn = "d:\重命名文件"     mypath = .LookIn    .FileType = msoFileTypeAllFiles     If .Execute > 0 Then         For i = 1 To .FoundFiles.Count             a = .FoundFiles(i)             Workbooks.Open (a)             b = Sheets(1).[a1].Text             Workbooks(Right(a, Len(a) - Len(mypath) - 1)).Close SaveChanges:=False             Dim OldName, NewName             OldName = a: NewName = mypath & "\" & b & ".xls"             On Error Resume Next             Name OldName As NewName             If Err.Description <> "" Then                GoTo line1             End Ifline2:         Next i     End IfEnd WithApplication.ScreenUpdating = TrueExit Subline1:MsgBox "已有“" & b & "”文件，或“" & b & "”不符合文件名要求，请检查后重新更改。"GoTo line2End Sub 雨霖铃:  程序非常简洁易懂，使用FileSearch方法寻找指定文件夹（无选择性），用Name方法更名。对重命名，空白项，无效字符给予了文本框提示，但未作处理。  ------------------------------- Uranus1997--------------------------------- Uranus1997:  使用Inputbox获取文件夹路径，同时采用了字典对象，这一部分我一点不懂，同时我的机器一直提示Right工程或库不存在，所以我未做验证。 ------------------------------- Ljw17--------------------------------- Ljw17:  由于必须安装了common dialogs控件，程序才能运行，我也不知道该如何验证。    这两份答案请qee用大师来为我们验证点评吧！[em04]

lpz001 · 发表于 2007-3-28 21:04

和大家相比，我的很差，我就不拿出来显丑了，我又钻了个空子，版主未要求出题的一定要做題！水平有限，请大家多谅解，后面有请qee用大师来精确评点吧！  [em04][em04]

[此贴子已经被作者于2007-3-28 21:34:13编辑过]

uranus1997 · 发表于 2007-3-28 22:37

<div class="msgheader">QUOTE:</div><div class="msgborder">以下是引用lpz001在2007-3-28 20:47:18的发言：                        Uranus1997:  使用Inputbox获取文件夹路径，同时采用了字典对象，这一部分我一点不懂，同时我的机器一直提示Right工程或库不存在，所以我未做验证。  </div>        呃...... 不好意思，我写这个代码的时候多手添加了一个与此无关的行业对象......        打开编辑器，工具→引用，把“ 丢失Echo3D 1.0 Type Library ”前面的勾去掉，程序就可以运行了。如果还有其他对象丢失，就都把显示丢失的对象前面的钩去掉把，我的代码没用特殊的对象。

[此贴子已经被作者于2007-3-28 23:11:54编辑过]

qee用 · 发表于 2007-3-28 23:04

呵呵,来晚了,我先看看~~~lpz001MM辛苦了.Uranus1997的代码运行正确.你那儿应该可以运行的,有一些在她那儿常用的第三方运行库,上传时忘了取消,所以到你的机器上就出错了.在VBE中,从工具-引用,把丢失的引用取消掉,就可以运行了.Ljw17的代码运行正确,特点他在附件中已经说明了.点评的很好.大家每个人都有自己的看法,所以本来就没有标准,只要我们在这中间能学到知识并快乐就可以了.请公布比赛结果吧.

uranus1997 · 发表于 2007-3-28 23:23

学到怎样调出文件选择对话框和设置参数了[em01]

danielcm · 发表于 2007-3-29 09:57

请公布[VBA接力赛第二期]结束，下一期由谁来接棒？还有，请兰老师、qee用、流星、烟雨江南、菜班长等等等等高手们也来参与一下，你们见多识广、考虑周全，题出的一定很好。我代表一班的同学们欢迎高手们参与，让我们见识一下VBA的魅力。

lpz001 · 发表于 2007-3-29 19:26

下一期就由danielcm长老接棒吧，我个人比较喜欢“打开”对话框，熟悉就亲切吧！反思这一期，热热闹闹的开了场，到头来发现我竟然收不了场，学海无漄，我要学习的还太多太多。感谢qee用大师给了我这次机会，这是当头的一棒，让我认识到：人，不能浮燥！qee用大师，请参考danielcm长老的意见，我深有此感，真的是心有余而力不足！多谢大家的参与，参与者应该都有3个金币吧，danielcm长老就是8个啦。发金币应该是qee大师的事情了，那么我谢幕啦…… [em04][em04][em04][em04][em04]

兰色幻想 · 发表于 2007-3-29 20:57

lpz001 辛苦了,我也很想参与VBA竟赛,可最近忙于等级考试,没有时间和精力参与,这期结束了,那你把获奖名称列个清单吧,我负责进行金币奖励。

qee用 · 发表于 2007-3-29 22:05

呵呵~MM~~~等等~~~~

4.对版主参赛不作为优胜者评选，如具备当期优胜者条件，则优胜者顺延至非版主会员。版主只作为候补出题者在优胜者放弃出题又无候补优胜者时保证接力正常进行。

danielcm版主作为候补出题者,请从Uranus1997和Ljw17中指定优胜者.

		自动登录	找回密码
密码			注册

[VBA接力赛第2期]批量更改文件名[已总结]

这是本次比赛的答案：