【源码示例】批量移动文件夹到指定文件夹

末蓝、 2022-05-24 07:23 784阅读 0赞

最近实习遇到的问题，需要筛一些文件夹出来，手动操作实在是繁琐，以下方法亲测好用。

后期的想法是把这个宏打包一下，变成独立的一个小工具，也许可迁移性会更强。

目前这个只要把目标移动路径和数据库文件放在同一子目录下就可以了，基本上是文件夹之间的移动，配合文件名快速生成还是很强大的，感觉能够提高不少效率。

目标是在access里实现，接下来看看能不能迁移到excel里，不知道会产生什么问题，VBA宏编程这一块比较不熟，慢慢加强一下吧。感觉还是很好用的。至少微软自己的工具可以直接从底层调用，这样的话还是开森。

摘　要:通过引用Microsoft Scripting Runtime动态库， fso.Movefolder函数和自定义函数实现了文件夹的批量移动。

正　文:  
  
  
一直想将取好文件名称的待办工作移动到已完成工作中，这样就可以直接了当的看出来还有多少工作未完成，一个一个移，确实有点麻烦。如果能实现文件夹的批量移动，那么就可以不费力的将已完成工作移动到指定文件夹。然而搜索了很多实例，都没有可以参考的ACCESS示列，使得我的想法无法实现。但还是功夫不负有心人，经过百度搜索了解了Microsoft Scripting Runtime动态库，及移动文件的相关函数，实现了单个文件的移动，算是有了些头绪，至少知道了用什么函数。  
'移动文件夹  
Public Sub Movefolder\_fso()  
    Dim fso As New FileSystemObject  
    Dim strSfolder As String  
    Dim strDfolder As String  
    strSfolder = CurrentProject.Path & "\\测试1"  
    strDfolder = CurrentProject.Path & "/MoveFile/"  
     
 If Not fso.FolderExists(strSfolder) Then  
        MsgBox " 文件夹不存在.", vbCritical  
    Else  
        fso.Movefolder strSfolder, strDfolder  
        MsgBox "已将文件移动到 " & strDfolder  
    End If  
    Set fso = Nothing  
End Sub  
  
  
后来通过参考批量文件命名的编写思路，先实现单个文件的移动，再逐条检索实现批量移动，写成了一个自定义函数。  
'批量文件夹移动  
'需要引用Microsoft Scripting Runtime动态库  
Public Sub FMovefolder\_fso()  
    Dim fso As New FileSystemObject  
    Dim strSfolder As String  
    Dim strDfolder As String  
    Dim rs As ADODB.Recordset  
    Dim str As String  
    Dim i, countY As Integer  
  
  
    str = "select \* from tbl\_wj where xz=true and (not isnull(bh))"  
    Set rs = getrs(str)  
    countY = 0  
    strDfolder = CurrentProject.Path & "/MoveFile/"  '目的文件路径  
    For i = 0 To rs.RecordCount - 1  
        strSfolder = CurrentProject.Path & "/" & rs!bh    '需要移动的文件路径  
        If fso.FolderExists(strSfolder) Then  
            fso.Movefolder strSfolder, strDfolder  
            countY = countY + 1  
            With rs  
                !zt = True  
                .Update  
            End With  
        Else  
            MsgBox " " & rs!bh & "文件夹不存在", vbCritical  
        End If  
        rs.MoveNext  
    Next  
    MsgBox "您已移动了" & countY & "个文件，请到相应目录下检查！"  
End Sub

经过多交测试后成功。但在使用过程中发现，不能跨越两个本地磁盘，也不能自定义相同磁盘的不同文件夹。还请大家帮忙一起完善。

工程的包在这里下载：[从这里下载][Link 1]

原文链接：[http://www.accessoft.com/article-show.asp?id=8154][http_www.accessoft.com_article-show.asp_id_8154]

[Link 1]: http://http//www.accessoft.com/article_attached/2013/file/201304/201304121926165029.rar
[http_www.accessoft.com_article-show.asp_id_8154]: http://http//www.accessoft.com/article-show.asp?id=8154