批处理之家 - Powered by Discuz! Board

' 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