Zip覆盖修复

时间:2016-05-17 18:36:30

标签: vbscript

我应该在此前言,并说我对Vb Script非常新。我有一些C#的经验,感觉非常相似。我正在努力完成一项工作任务。

此任务将查找某个位置,并查找早于特定日期的所有文件。然后脚本将获取所有这些文件,并根据zip文件的月份将它们压缩到zip文件夹中。此任务将每月运行。编写的原始剧本(阅读:谷歌拼凑而成)在小样本上运行良好。但是当应用于具有超过10K文件的文件夹时,它在大约3000个文件之后被轰炸并停止存档。

然后我决定每周运行一次脚本以降低影响。理想情况是每周运行一次,并将所有文件编译成一个以该月命名的zip文件。因此脚本运行may的第一个星期一,并将100个文件放在“May”文件夹中。然后在第二个星期一,该脚本再次运行并将所有文件放入相同的May压缩文件中。我遇到的问题是它是否覆盖了当前文件。

这是我的代码。有什么建议吗?

OriginalDir = "C:\Users\me\Desktop\Log_Test\Test"

DoZips(OriginalDir)

Function DoZips(Dir1)

'create empty zip file

a = Split(Dir1,"\",-1)

MyZip = Dir1 & "\" & MonthName(Month(Now)-1) & "_" & "archive" & ".zip"     'Naming of the zip file

CreateObject("Scripting.FileSystemObject") _
.CreateTextFile(MyZip, True) _
.Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)

'zip content into zip file

on error resume next

Set oFS = CreateObject("Scripting.FileSystemObject")

Set oFolder = oFS.GetFolder(Dir1)

For Each File In oFolder.Files

    If Right(LCase(file.path),4) <> ".zip" Then

        If File.DateLastModified < Date Then        'Change this number to set the age cutoff

            With CreateObject("Shell.Application")

                .NameSpace(MyZip).CopyHere File.path        'Copy the file to the zip folder

                    wScript.Sleep 4000      'Set wait time between archive and delete to ensure complete file archive

            file.delete     'Delete the file after archive      

            End With

        End If

    End If

Next

CreateObject("WScript.Shell").Popup "All Files in " & myZip & " Successfully zipped", 5, "Compression"



set ObjFSO = CreateObject("Scripting.FileSystemObject")
Set ObjLog = objFSO.CreateTextFile("C:\Users\me\Desktop\Log_Test\log.txt")
objLog.WriteLine nCompressed & " of" & ubound(arFiles) + 1 &_
" Eligible files were compressed and zipped to location " & myZip & " on " & Date

End Function

1 个答案:

答案 0 :(得分:1)

您的CreateTextFile调用,将True作为覆盖参数传递,这意味着您每次都会创建一个新的空zip文件...

首先检查当前月份的文件是否存在,只有当文件尚未存在时才创建该文件...