除性删除的VBS脚本（删除指定以外的目录、文件）

Option Explicit

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

Function InGroup(strGroup,CName)
dim Group1,Group2,GroupArr1,GroupArr2
Group1="NET117;NET118"       '这里是A类的机器名
Group2="NET004;NET120;124"     '这里是B类的机器名
GroupArr1=Split(Group1,";")
GroupArr2=Split(Group2,";")
InGroup = False
If strGroup = "A类" Then
    If InArray(GroupArr1,CName) Then
        InGroup = True
    End If
End If
If strGroup = "B类" Then
    If InArray(GroupArr2,CName) Then
        InGroup = True
    End If
End If
End Function

Dim WshNetwork,computer
Set WshNetwork = WScript.CreateObject("WScript.Network")
computer = WshNetwork.ComputerName

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,appGroupArr
Do While objListfile.AtEndOfStream <> True
    Myline = LCase(Replace(objListfile.ReadLine,"==","="))
    If Left(Myline,1) = "/" Then
    'objListfile.SkipLine
    ElseIf CheckLine(Myline) = 3 Then
        LineArr = Split(Myline,"=")
        If InGroup(LineArr(0),computer) Then
            ListArr = Split(LineArr(3),";")
            If LineArr(1) = "目录" Then DelFolder LineArr(2),ListArr
     If LineArr(1) = "目录" Then CreFolder LineArr(2),ListArr
            If LineArr(1) = "文件" Then DelFile LineArr(2),ListArr
        End if
    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
        flnum = flnum + 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
        fdnum = fdnum + 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

Sub CreFolder(path,arrFodName)
Dim Strpath,StrTemp
If Right(path,1)<>"\" Then path = path&"\"
For Each StrTemp In arrFodName
Strpath = path & StrTemp
    If Not Fso.FolderExists(Strpath) Then
        Fso.CreateFolder(Strpath)
    End If
Next
End Sub