[原创] VBS清除指定文件类型的文件(安全删除，艳照删除用，能找回来算你狠)

yu2n

清除指定文件类型的文件(安全删除，能找回来算你狠) By Yu2n 2013-07-30
功能：清理相机SD卡内艳照。
原理：重命名+复写+删除
作者：Yu2n

' Safa_Clear_Folder.vbs
' +----------------------------------------------------------------------------+
' | 清除指定文件类型的文件(安全删除，能找回来算你狠) By Yu2n 2013-07-30 |
' +----------------------------------------------------------------------------+
On Error Resume Next
Dim sTitle, sMeDir, sFolder, sFileType, sQuery
sTitle = "文件完全删除工具"
sMeDir = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName,"\")-1)

' 取得文件夹路径
sFolder = BrowseForFolder("警告：删除文件后，工具软件无法找回！！" & vbCrLf & vbCrLf & "请选择要清理的文件夹：")
If sFolder = "" Then sFolder = sMeDir
' 取得文件类型
sFileType = InputBox(  "請輸入要清理的文件类型：" & vbCrLf & _
                    vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & _
                    "使用正则表达式，默认清理所有文件夹", _
                    sTitle, "(jpg|mp4)")
' 最后确认
sQuery = Msgbox("警告：删除文件后，工具软件无法找回！" & vbCrLf & vbCrLf & _
                "清理文件夹：" & sFolder & " (默认本程序位置)" & vbCrLf & vbCrLf & _
                "是否确认？" & vbCrLf , _
                vbYesNo + 64, sTitle)
                
If Not sQuery = vbYes Then WScript.Quit

' 清理
CleraFolder sFolder, sFileType

'结束
Msgbox "提示：操作完成！            ", 64, sTitle

' +----------------------------------------------------------------------------+
' | 清除指定文件类型的文件(安全删除) |
' +----------------------------------------------------------------------------+
Function CleraFolder(ByVal strFolderPath, ByVal strFileType)
    Dim oScanDir, sFileList, sFolderList
    ' 创建对象
    Set oScanDir = New Scan_Folder
    ' 指定文件夹
    oScanDir.FolderSpec strFolderPath
    ' 设定扫描最大层数(可为空。默认扫描所有子文件夹)
    'oScanDir.MaxLayer 2
    ' 指定文件类型(可为空。正则表达式规则，默认则返回所有文件)
    oScanDir.FileType_RegExPatternt strFileType
    ' 获取结果(必填。GetFileList返回文件列表，GetFolderList返回目录列表，GetEmptyFolderList返回空目录列表)
    sFileList = oScanDir.GetFileList
    ' 结束对象
    oScanDir.Close
    
    'WScript.Echo "文件列表：" & vbCrLf & sFileList
    
    ' 对所有子文件进行处理
    Dim arrFilePath
    arrFilePath = Split(sFileList, vbCrLf, -1, vbTextCompare) 
    For i = 0 To UBound(arrFilePath)
        strFilePath = arrFilePath(i)
        'WScript.Echo "strFilePath  _" & strFilePath & "_"
        ClearFileDate strFilePath
    Next
    
    ' 清空文件夹，删除所有子目录
    REM Set fso = CreateObject("Scripting.FileSystemObject")
    REM If (fso.FolderExists( strFolderPath )) Then
        REM fso.GetFolder( strFolderPath ).attributes = 0
        REM fso.GetFolder( strFolderPath ).delete
    REM End If
    REM If Not fso.FolderExists( strFolderPath ) Then fso.CreateFolder( strFolderPath )
    REM Set fso = Nothing

End Function

' +----------------------------------------------------------------------------+
' | 清除文件 |
' +----------------------------------------------------------------------------+
Function ClearFileDate(ByVal sFilePath)
    Dim fso, oFile
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(sFilePath) = True Then
        Set oFile = fso.GetFile(sFilePath)
        oFile.Attributes = 0
        sFolderPath = fso.GetParentFolderName(oFile)
        ' 重命名
        sFileNameNew = GetGUID()
        oFile.Name = sFileNameNew
        sFilePathNew = sFolderPath & "\" & sFileNameNew
        ' 覆盖数据
        SetLocale "en-us"
        set wtxt = fso.OpenTextFile(sFilePathNew, 2, True, -1)
        wtxt.Write sFileNameNew & VbCrLf & Now()
        wtxt.Close()
        ' 删除
        Set oFile = fso.GetFile(sFilePathNew)
        oFile.Delete
    End If
End Function

' +----------------------------------------------------------------------------+
' | 递归查找文件类：可自定义扫描目录层数、文件类型 |
' +----------------------------------------------------------------------------+
Class Scan_Folder
    ' ==============================================================================================================
    ' 类初始化
    ' ==============================================================================================================
    ' 公共变量
    Private fso, regEx, sFolderSpec, sParentFolderLayer, sMaxLayer, sFileType_RegExPatternt, sFileType, sFileList, sFolderList, sEmptyFolderList
    Private ScanFolderOnly, ScanSubFolder
    '类初始化事件
    Private Sub Class_Initialize
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set regEx = CreateObject("VBScript.RegExp")     ' 建立正则表达式。
            regEx.IgnoreCase = True     ' 设置是否区分大小写。
            regEx.Global = True         ' 设置全局替换。
            regEx.MultiLine = True      ' 设置多行匹配模式
        ScanFolderOnly = True           ' 仅扫描文件夹(提高效率)
        ScanSubFolder = True            ' 扫描子文件夹
    End Sub
    ' ==============================================================================================================
    ' 获取设定
    ' ==============================================================================================================
    ' 设置扫描目录
    Public Function FolderSpec(ByVal strFolderSpec)
        sFolderSpec = strFolderSpec
    End Function
    ' 设置最大扫描目录层数
    Public Function MaxLayer(ByVal strMaxLayer)
        sMaxLayer = strMaxLayer
    End Function
    ' 设置扫描的文件类型
    Public Function FileType_RegExPatternt(ByVal strFileType_RegExPatternt)
        sFileType_RegExPatternt = strFileType_RegExPatternt
    End Function
    ' 获取文件夹列表(包括空文件夹)
    Public Function GetFolderList()
        ScanFolderOnly = True
        Scan_Layer sFolderSpec
        GetFolderList = sFolderList
    End Function
    ' 获取空文件夹列表
    Public Function GetEmptyFolderList()
        ScanFolderOnly = False
        Scan_Layer sFolderSpec
        GetEmptyFolderList = sEmptyFolderList
    End Function
    ' 获取文件列表
    Public Function GetFileList()
        ScanFolderOnly = False
        Scan_Layer sFolderSpec
        GetFileList = sFileList
    End Function
    ' 关闭控件
    Public Sub Close()
        Set fso = Nothing
        Set regEx = Nothing
    End Sub
    ' ==============================================================================================================
    ' 私有函数
    ' ==============================================================================================================
    ' 递归扫描
    Private Function Scan_Layer(strFolderspec)
        On Error Resume Next
        If Not Right(strFolderspec,1) = "\" Then strFolderspec = strFolderspec & "\"
        If Not IsEmpty(sFolderList) Then sFolderList = sFolderList & vbCrLf
        sFolderList = sFolderList & strFolderspec
        ' 文件夹对象
        Dim oFolder, oSubFolderItems, oSubFileItems, oSubFolder, oSubFile
        Set oFolder = fso.GetFolder(strFolderspec)
        ' 是否扫描 当前文件夹 的 子文件
        If ScanFolderOnly = False Then
            ' 子文件对象集合
            Set oSubFileItems = oFolder.Files
            ' 查找当前文件夹 的 文件
            If oSubFileItems.Count <> 0 Then
                For Each oSubFile In oSubFileItems
                    If IsEmpty(sFileType_RegExPatternt) Or (sFileType_RegExPatternt = "") Then
                        If Not IsEmpty(sFileList) Then sFileList = sFileList & vbCrLf
                        sFileList = sFileList & oSubFile.Path
                    Else
                        ' 过滤文件类型(适用正则表达式)
                        regEx.Pattern = sFileType_RegExPatternt
                        If regEx.Execute( fso.GetExtensionName(oSubFile) ).Count > 0 Then
                            If Not IsEmpty(sFileList) Then sFileList = sFileList & vbCrLf
                            sFileList = sFileList & oSubFile.Path
                        End If
                    End If
                Next
            End If
        End If
        ' 查找当前文件夹 的 子文件夹
        Set oSubFolderItems = oFolder.SubFolders        ' 子文件夹对象集合
        ' --------没有子文件夹时
        If oSubFolderItems.Count = 0 Then
            ' --------也没有子文件时(此文件夹为空)
            If ScanFolderOnly = False Then
                If oSubFileItems.Count = 0 Then
                    If Not IsEmpty(sEmptyFolderList) Then sEmptyFolderList = sEmptyFolderList & vbCrLf
                    sEmptyFolderList = sEmptyFolderList & strFolderspec
                End If
            End If
        Else
            ' 限制递归的最大层数
            If Not (IsEmpty(sMaxLayer) Or (sMaxLayer = "")) Then
                Dim s, f, n
                s = Replace(strFolderspec, sFolderSpec, "", vbTextCompare, -1, 1)
                f = "\"
                n = (len(s)-len(replace(s,f,"",vbTextCompare,-1,1)))/len(f)    ' 统计字符串中某一单词出现次数
                If sMaxLayer < n Then ScanSubFolder = False
            Else
                ScanSubFolder = True
            End If
            If ScanSubFolder = True Then
                ' ----有子文件夹时，递归查找
                For Each oSubFolder In oSubFolderItems
                    'sFolderList = sFolderList & oSubFolder.Path & vbCrLf
                    Scan_Layer oSubFolder.Path
                Next
            End If
        End If
    End Function
End Class
' 实例
Function DemoScanDir()
    Dim oScanDir, sInfo
    ' 创建对象
    Set oScanDir = New Scan_Folder
    ' 指定文件夹
    oScanDir.FolderSpec "G:\DCIM\.BACKUP\20130717"
    ' 设定扫描最大层数(可为空。默认扫描所有子文件夹)
    oScanDir.MaxLayer 1
    ' 指定文件类型(可为空。正则表达式规则，默认则返回所有文件)
    oScanDir.FileType_RegExPatternt "(jpg|mp4|css|7z)"
    ' 获取结果(必填。GetFileList返回文件列表，GetFolderList返回目录列表，GetEmptyFolderList返回空目录列表)
    DemoScanDir = oScanDir.GetFileList
    ' 结束对象
    oScanDir.Close
End Function

' +----------------------------------------------------------------------------+
' | 生成GUID http://demon.tw/programming/generate-guid-in-vbs.html  |
' +----------------------------------------------------------------------------+
Function GetGUID()
    Set TypeLib = CreateObject("Scriptlet.TypeLib")
    GetGUID = Left(TypeLib.Guid,38)
End Function


' +----------------------------------------------------------------------------+
' | 浏览文件夹 ' File:Dialog.vbs (WSH sample in VBScript)   |
' |              Author:(c) G. Born                         |
' +----------------------------------------------------------------------------+
Function BrowseForFolder(ByVal sTips)
    Const BIF_returnonlyfsdirs = &H0001
    Const BIF_editbox= &H0010
    Dim oShell, oFolder
    BrowseForFolder = ""
    Set oShell = CreateObject("Shell.Application")
    Set oFolder = oShell.BrowseForFolder(&H0, sTips, BIF_editbox + BIF_returnonlyfsdirs)
    If InStr(1, TypeName(oFolder), "Folder") > 0 Then
        BrowseForFolder = oFolder.Items().Item().Path
    End If
End Function
复制代码

yu2n

之前有写一个BAT版，写这个是个人爱好。
里面那个类是自己写的，有点烂。

BAT代码如下：

:: Safa_Clear_Folder.bat

@echo off
setlocal enableDelayedExpansion
rem ---要清理的文件夹目录
echo,警告：删除文件后，工具软件无法找回！！
set /p "wkDir=请输入要清理的文件夹："
if not exist "!wkDir!" exit

cls
echo,警告：删除文件后，工具软件无法找回！
echo,即将清理文件夹：!wkDir! 
pause

rem ---扫描文件夹
for /f "tokens=1 delims==" %%i in ('dir /a-d /b /s "%wkDir%"') do (
    set "wkDir=%%~dpi"
    set "wkDir=!wkDir:~0,-1!"
    set "wkFileName=%%~nxi"
    set "wkFilePath=%%~i"
    
    REM ---取消文件属性
    attrib -a -s -h -r "%%~fi"
    
    REM ---文件名随机重命名
    call :get_sRandom
    if exist "!wkDir!\!sRandom!" (
        ping -n 3 127.1 >nul 2>nul & call :get_sRandom
    )
    rename "!wkFilePath!" "!sRandom!"
    
    REM ---覆写及删除文件
    echo,!sRandom!>"!wkDir!\!sRandom!"
    echo,DEL !wkDir!\!sRandom!
    del /q "!wkDir!\!sRandom!"
)

echo,清理完成！！
pause


rem ---生成随机字符串
goto :eof
:get_sRandom
    set "sRandom="
    set "sTime=%date:~0,4%%date:~5,2%%date:~8,2%%time:~0,2%%time:~3,2%%time:~6,2%%time:~9,2%"
    set "p=ABCDEFGHIJ"
    for /l %%a in (0 1 9) do set "#!random!!random!!random!=!p:~%%a,1!"
    for /f "tokens=1,2 delims==" %%a in ('set #') do (set "%%a="&set "sRandom=!sRandom!%%b")
    set "sRandom=!sTime!!sRandom!"
复制代码

523066680

前排支持   

523066680

其实重复 for + 'set #' 累计耗时是比较多的。

@echo off
set t=%time%
setlocal enabledelayedexpansion

for /l %%a in (1,1,100) do (call :get_sRandom)
echo %t% %time%
pause

rem ---生成随机字符串
:get_sRandom
    set "sRandom="
    set "sTime=%date:~0,4%%date:~5,2%%date:~8,2%%time:~0,2%%time:~3,2%%time:~6,2%%time:~9,2%"
    set "p=ABCDEFGHIJ"
    for /l %%a in (0 1 9) do set "#!random!!random!!random!=!p:~%%a,1!"
    for /f "tokens=1,2 delims==" %%a in ('set #') do (set "%%a="&set "sRandom=!sRandom!%%b")
    set "sRandom=!sTime!!sRandom!"
    echo !sRandom!
    goto :eof
复制代码

另外写了一个随机提取的方法，对比下时间：

@echo off
set t=%time%
setlocal enabledelayedexpansion

for /l %%a in (1,1,100) do (call :get_sRandom)
echo %t% %time%
pause

rem ---生成随机字符串
:get_sRandom
    set "sRandom="
    set "sTime=%date:~0,4%%date:~5,2%%date:~8,2%%time:~0,2%%time:~3,2%%time:~6,2%%time:~9,2%"
    set "p=ABCDEFGHIJ"
    for /l %%a in (9,-1,1) do (
        set /a R=!random! %% %%a
        for %%b in (!R!) do set GetSR=!p:~%%b,1!
        for %%c in (!GetSR!) do set p=!p:%%c=!
        set sRandom=!sRandom!!GetSR!
    )
    set "sRandom=!sTime!!sRandom!"
    echo !sRandom!
    goto :eof
复制代码

yu2n

回复 4# 523066680

不错，这部分代码你的效率很高，比我的高大约十倍。

yu2n

其实重复 for + 'set #' 累计耗时是比较多的。另外写了一个随机提取的方法，对比下时间：
523066680 发表于 2013-7-31 17:22

    既然如此，来个高效删除的BAT版文件清除删除器

:: Safe_Clear_Folder.cmd

@echo off
setlocal enableDelayedExpansion
rem ---要清理的文件夹目录
echo,警告：删除文件后，工具软件无法找回！！
set /p "wkDir=请输入要清理的文件夹："
if not exist "!wkDir!" exit

cls
echo,警告：删除文件后，工具软件无法找回！
echo,即将清理文件夹：!wkDir! 
pause

rem ---扫描文件夹
for /f "tokens=1 delims==" %%i in ('dir /a-d /b /s "%wkDir%"') do (
    set "wkDir=%%~dpi"
    set "wkDir=!wkDir:~0,-1!"
    set "wkFileName=%%~nxi"
    set "wkFilePath=%%~i"
    
    REM ---取消文件属性
    attrib -a -s -h -r "%%~fi"
    
    REM ---文件名随机重命名
    call :get_sRandom
    if exist "!wkDir!\!sRandom!" (
        ping -n 3 127.1 >nul 2>nul & call :get_sRandom
    )
    rename "!wkFilePath!" "!sRandom!"
    
    REM ---覆写及删除文件
    echo,!sRandom!>"!wkDir!\!sRandom!"
    echo,DEL !wkDir!\!sRandom!
    del /q "!wkDir!\!sRandom!"
)

echo,清理完成！！
pause


rem ---生成随机字符串
goto :eof
:get_sRandom
    set "sRandom="
    set "sTime=%date:~0,4%%date:~5,2%%date:~8,2%%time:~0,2%%time:~3,2%%time:~6,2%%time:~9,2%"
    set "p=ABCDEFGHIJ"
    for /l %%a in (9,-1,1) do (
        set /a R=!random! %% %%a
        for %%b in (!R!) do set GetSR=!p:~%%b,1!
        for %%c in (!GetSR!) do set p=!p:%%c=!
        set sRandom=!sRandom!!GetSR!
    )
    set "sRandom=!sTime!!sRandom!"
    goto :eof
复制代码