使用脚本自动压缩指定目标下的所有文件的代码

2020-07-26 11:49:39

字体：大中小

来源：转载

供稿：网友

为了解决这类问题，我使用Visual Basic Scripting设计了一个脚本，可以自动达到这个目标。在本脚本中，自动压缩所有文件。为了避免将脚本自己也压缩进去，使用了一些判断。

复制代码代码如下:

 
call main() 
Sub main() 
Dim fs '文件系统。 
Dim f 'folder 
Dim fc 'files 
Dim s 'string 
Dim ws 'SHELL。 
Dim subfs 
Dim fi 
'创建SHELL。 
Set ws = CreateObject("WScript.Shell") 
'创建文件对象。 
Set fs = CreateObject("Scripting.FileSystemObject") 
Set f = fs.GetFolder(ws.currentdirectory) 
Handle_files(ws.currentdirectory) 
Set subfs = f.SubFolders 
'遍历每个子目录。 
For Each fi In subfs 
Call ListSub(fi.Path) 
Next 
End Sub 
Sub ListSub(filename) 
On Error Resume Next 
Dim subfs '子目录。 
'首先处理当前目录。 
Handle_Files(filename) 
'创建文件对象。 
Set fs = CreateObject("Scripting.FileSystemObject") 
Set f = fs.GetFolder(filename) 
Set subfs = f.SubFolders 
For Each fi In subfs 
Call ListSub(fi.Path) 
Next 
End Sub 
'处理每个目录下的文件。 
Sub Handle_Files(foldername) 
'创建文件对象。 
Set fs = CreateObject("Scripting.FileSystemObject") 
Set f = fs.GetFolder(foldername) 
Set fc = f.Files 
'创建SHELL。 
Set ws = CreateObject("WScript.Shell") 
'遍历文件对象。 
For Each fl In fc 
if ((instr(fl.Name,"vbs") = 0) and (instr(fl.Name,"rar") = 0)) then 
'进行压缩。 
s = "winrar M -ep " & fl.Path & ".rar " & fl.Path 
ws.Run s, 0, True 
End If 
Next 
End Sub 
sub output(string) 
wscript.echo string 
end sub 

一种更加巧妙的方法
对上个脚本稍加改动，使用正则表达式（Regular Expression ），可以方便我们的判断过程。修改后的脚本程序如下所示。注意我们这里排除的是不压缩的文件类型。

复制代码代码如下:

 
call main() 
Sub main() 
Dim fs '文件系统。 
Dim f 'folder 
Dim fc 'files 
Dim s 'string 
Dim ws 'SHELL。 
Dim subfs 
Dim fi 
'创建SHELL。 
Set ws = CreateObject("WScript.Shell") 
'创建文件对象。 
Set fs = CreateObject("Scripting.FileSystemObject") 
Set f = fs.GetFolder(ws.currentdirectory) 
Handle_files(ws.currentdirectory) 
Set subfs = f.SubFolders 
'遍历每个子目录。 
For Each fi In subfs 
Call ListSub(fi.Path) 
Next 
End Sub 
Sub ListSub(filename) 
On Error Resume Next 
Dim subfs '子目录。 
'首先处理当前目录。 
Handle_Files(filename) 
'创建文件对象。 
Set fs = CreateObject("Scripting.FileSystemObject") 
Set f = fs.GetFolder(filename) 
Set subfs = f.SubFolders 
For Each fi In subfs 
Call ListSub(fi.Path) 
Next 
End Sub 
'处理每个目录下的文件。 
Sub Handle_Files(foldername) 
'创建文件对象。 
Set fs = CreateObject("Scripting.FileSystemObject") 
Set f = fs.GetFolder(foldername) 
Set fc = f.Files 
'创建SHELL。 
Set ws = CreateObject("WScript.Shell") 
'遍历文件对象。 
For Each fl In fc 
if ( RegExpTest(".vbs|.rar|.zip",fl.name) = false) then 
'进行压缩。 
s = "winrar M -ep " & fl.Path & ".rar " & fl.Path 
output s 
ws.Run s, 0, True 
End If 
Next 
End Sub 
sub output(string) 
wscript.echo string 
end sub 
'使用正则表达式进行判断。 
Function RegExpTest(patrn, strng) 
Dim regEx, retVal ' Create variable. 
Set regEx = New RegExp ' Create regular expression. 
regEx.Pattern = patrn ' Set pattern. 
regEx.IgnoreCase = False ' Set case sensitivity. 
retVal = regEx.Test(strng) ' Execute the search test. 
If retVal Then 
RegExpTest = true 
Else 
RegExpTest = false 
End If 
End Function 