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

时　间:2013-04-12 19:25:57
作　者:天外流星   ID：28406  城市：江门
摘　要:通过引用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

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

点击下载此附件