请高手帮忙解析一个关于备份的代码

zhulx_wx

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    Application.ScreenUpdating = False
    Dim LastBackUpDate As Date, TheBackUpDir As String, filename As String, i%
    Dim f As Object, gfile_name As String, gfile As Object
    Dim Fso As Object
    With ActiveWorkbook
            .Sheets.Copy
            .Save
    End With '先存盘,再备份
    Set Fso = CreateObject("Scripting.FileSystemObject")
    filename = Left((ThisWorkbook.Name), InStr(1, ThisWorkbook.Name, ".") - 1)
    TheBackUpDir = "D:\备份"
    'On Error Resume Next
    If Len(Dir(TheBackUpDir, vbDirectory)) = 0 Then
        MkDir TheBackUpDir '如果没有备份文件夹,则新建
    Else: Set f = Fso.GetFolder(TheBackUpDir) '如果已经存在,则遍历备份文件夹
    For Each gfile In f.Files
        gfile_name = Left((Fso.getbasename(gfile)), 5) '提取文件名的主要字符串
        LastBackUpDate = f.DateLastModified '提取文件的修改时间
        If gfile.fileExists(TheBackUpDir) = False Or ((gfile_name Like filename) And (Date - LastBackUpDate > 6)) Then
         '如果文件不存在,或者文件已经存在并且存在时间已经超过6天,则进行备份
            With ThisWorkbook
            .SaveAs filename:=TheBackUpDir & "\" & filename & "_" & Format(Date, "yyyymmdd")
            End With
        End If
    Next
    End If
    Application.ScreenUpdating = True
End Sub

目前的问题:
1.点击存盘后,就会跳出新的表单"book1.xlsx",一点又会跳出"book2.xlsx",不知是什么原因?
2.运行到For Each gfile In f.Files,就会直接跳到End Sub,不知是不是架构有问题?


本人是新手,一直在努力学习中,问题提得会比较呆萌,
还请各位高手帮忙指点,万分感谢!

zhulx_wx

国庆节大家是不是已经休息了啊?
还有高手能帮忙吗?

t13564865256

这个方法被递归调用了。

zhulx_wx

t13564865256 发表于 2015-9-30 12:17
这个方法被递归调用了。

小灰兔,您能告诉我该怎么改吗?

zhulx_wx

还有高手能出手相助吗?

zhulx_wx

通过自己的分析,发现存在以下问题:
(1) BeforeSave中不能再Save,这将引起递归,造成反复打开,即引起第1条问题的原因;
(2)遍历中的关系存在问题,目前正在调试,
(3)程序最后忘了重置Fso=Nothing.

zhulx_wx

作了些调整,目前可以运行了!

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    Application.ScreenUpdating = False
    Dim LastBackUpDate As Date, TheBackUpDir As String, filename_bu As String, i%, file_name As String
    Dim f As Object, gfile_name As String, gfile As Object
    Dim Fso As Object
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Filename = Left((ThisWorkbook.Name), InStr(1, ThisWorkbook.Name, ".") - 1)
    TheBackUpDir = "D:\备份"
    'On Error Resume Next
    If Len(Dir(TheBackUpDir, vbDirectory)) = 0 Then
        MkDir TheBackUpDir '如果没有备份文件夹,则新建
    Else 'Set f = Fso.GetFolder(TheBackUpDir) '如果已经存在,则遍历备份文件夹
        filename_bu = TheBackUpDir & "\" & Filename & ".xls" 'Format(Date, "yyyymmdd") & ".xls"
        If Not Fso.FileExists(filename_bu) Or Date - Fso.GetFile(filename_bu).DateLastModified > 6 Then
             Kill filename_bu
             With ThisWorkbook
            .SaveAs filename_bu
         '如果文件不存在,或者文件已经存在并且存在时间已经超过6天,则进行备份
            End With
        End If
        'MsgBox Fso.GetFile(filename_bu).DateLastModified
    End If
    Application.ScreenUpdating = True
        Set Fso=Nothing
End Sub