用VBS脚本删除指定以外的文件或文件夹

好多情况下，我们只想保留某个文件或文件夹但对于大量的文件或文件夹删除起来，比较麻烦，下面这个代码可以解决这个问题，用vbs实现的删除文件夹代码

 

Option Explicit 

''''''''''''''说明'''''''''''' 
'网盟-黑火制作，送给需要的朋友。 
'配置文件“Listfile.ini”的格式如下： 
'要删除什么(文件|目录)=要执行删除的文件夹=排除1;排除2;排除3............ 
'配置文件可以有多行，以便对多个目录进行操作。 
'配置文件里以“/”开头的行为注释行。 
'排除多个内容时，使用分号“;”进行分隔。 
'↓↓↓ 配置文件例子：↓↓↓ 
'/配置文件开始 
'目录=D:/=System Volume Information;网络游戏;单机游戏;小游戏 
'目录=C:/Program Files=qq;WinRAR 
'文件=D:/网络游戏=文件1.exe;文件2.exe 
'/配置文件结束 
'''''''''''''说明完'''''''''''' 

Dim Fso,Listfile,objListfile 
Listfile = ""           '设置配置文件路径,如果配置文件和脚本放在一起，请保持原样 

If Listfile = "" Then Listfile = "Listfile.ini" 
Set Fso = CreateObject("Scripting.FileSystemObject") 
On Error Resume Next 
Set objListfile = Fso.OpenTextFile(Listfile,1) 
If Err Then 
     err.Clear 
     Msgbox "没有找到配置文件 "&Listfile,16,"错误" 
     WScript.quit 
End If 
On Error GoTo 0 

Dim flnum,fdnum,t1,t2,tm 
flnum=0 
fdnum=0 
t1 = timer() 

Dim Myline,LineArr,ListArr 
Do While objListfile.AtEndOfStream <> True 
     Myline = LCase(Replace(objListfile.ReadLine,"==","=")) 
     If Left(Myline,1) = "/" Then 
     'objListfile.SkipLine 
     ElseIf CheckLine(Myline) = 2 Then 
         LineArr = Split(Myline,"=") 
         'DoFolder = LineArr(1) 
         ListArr = Split(LineArr(2),";") 
   'MsgBox LineArr(0) 
         If LineArr(0) = "目录" Then DelFolder LineArr(1),ListArr 
         If LineArr(0) = "文件" Then DelFile LineArr(1),ListArr 
     End If 
Loop 

t2 = timer() 
tm=cstr(int(( (t2-t1)*10000 )+0.5)/10) 

MsgBox "扫描完毕，共删除 "&fdnum&" 个目录, "&flnum& "个文件。"& vbCrLf &"耗时 "&tm&" 毫秒",64,"执行完毕" 
'不需要显示报告的话，注释掉上面这一行 

Set Fso=NoThing 
WScript.quit 

Sub DelFolder(Folder,ListArr) 
Dim objFolder,subFolders,subFolder 
     Set objFolder=Fso.Getfolder(Folder) 
     Set subFolders=objFolder.subFolders 
     For Each subFolder In subFolders 
     If Not InArray(LIstArr,LCase(subFolder.name)) Then 
     On Error Resume Next 
         subfolder.Delete(True) 
         If Err Then 
             err.Clear 
             Msgbox "不能删除目录，请检查 "&subFolder,16,"错误" 
         Else 
         fdnum = fdnum + 1 
         End If 
         On Error GoTo 0 
     End If 
     Next 
End Sub 

Sub DelFile(Folder,ListArr) 
Dim objFolder,Files,File 
     Set objFolder=Fso.Getfolder(Folder) 
     Set Files=objFolder.Files 
     For Each File In Files 
     If Not InArray(LIstArr,LCase(File.name)) Then 
     On Error Resume Next 
         File.Delete(True) 
         If Err Then 
             err.Clear 
             Msgbox "不能删除文件，请检查 "&File,16,"错误" 
         Else  
         flnum = flnum + 1 
         End If 
         On Error GoTo 0 
     End If 
     Next 
End Sub 

Function CheckLine(strLine) 
Dim LineRegExp,Matches 
Set LineRegExp = New RegExp 
LineRegExp.Pattern = ".=." 
LineRegExp.Global = True 
Set Matches = LineRegExp.Execute(strLine) 
CheckLine = Matches.count 
End Function 

Function InArray(Myarray,StrIn) 
Dim StrTemp 
InArray = True 
For Each StrTemp In Myarray 
     If StrIn = StrTemp Then 
         Exit Function 
         Exit For 
     End If 
Next 
InArray = False 
End Function