批处理之家 - Powered by Discuz! Board

Dim fso, nFolder, nFile
nFile = 0
nFolder = 0
Set fso=CreateObject("Scripting.FilesyStemObject")
For Each arg In WScript.Arguments
If fso.FileExists(arg) Then nFile = nFile + 1
If fso.FolderExists(arg) Then nFolder = nFolder + 1
Next
WScript.Echo nFile & "个文件, " & nFolder & "个文件夹"
If nFile > 1 And nFolder = 0 Then
WScript.Echo "执行1：RAR 解压到文件夹……"
ElseIf nFolder > 0 Or nFile = 1 Then
WScript.Echo "执行2：RAR 直接解压……"
End If

复制代码

RAR 3.70 beta 8 版权 (C) 1993-2007 Alexander Roshal 5 五月 2007
已注册给 Mittal Steel Temirtau
压缩文件 d:\1.rar
路径名/注释
尺寸压缩率日期时间属性 CRC 方法版本
-------------------------------------------------------------------------------
1\2\6.txt
0 0 0% 12-07-14 17:12 .....A. 00000000 m0b 2.9
1\3\7\6.txt
0 0 0% 12-07-14 17:12 .....A. 00000000 m0b 2.9
1\4.txt
0 0 0% 12-07-14 17:12 .....A. 00000000 m0b 2.9
1\3\7
0 0 0% 12-07-14 17:12 .D..... 00000000 m0 2.0
1\2
0 0 0% 12-07-14 17:12 .D..... 00000000 m0 2.0
1\3
0 0 0% 12-07-14 17:12 .D..... 00000000 m0 2.0
1
0 0 0% 12-07-14 17:12 .D..... 00000000 m0 2.0
-------------------------------------------------------------------------------
7 0 0 0%

复制代码

Main
Sub Main
' 以命令行模式运行，可去掉(需要同时去掉WScript.Echo部分)
If InStr(1,WScript.FullName&"|","WScript.exe|",1)>0 Then
Dim i, sArgs
For i = 1 To WScript.Arguments.Count
sArgs = sArgs & " " & Chr(34) & WScript.Arguments(i-1) & Chr(34)
Next
CreateObject("WScript.Shell").Run("CScript.exe " & Chr(34) & Wscript.ScriptFullName & Chr(34) & sArgs),3
WScript.Quit(0)
End If
' 获取参数
If WScript.Arguments.Count = 0 Then
WScript.Echo "提示：没有参数。"
WScript.Quit(1)
Else
For Each arg In WScript.Arguments
Check arg
Next
WScript.Quit(0)
End If
End Sub
' 检查RAR文件，执行相应操作
Sub Check(file_rar)
Set wso = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
' 检测参数
If Not fso.FileExists(file_rar) Then
WScript.Echo "提示：参数不正确。"
WScript.Quit(2)
End If
' 检查 RAR.EXE 是否存在
RAR_EXE = wso.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\WinRAR.exe\path") & "\rar.exe"
RAR_EXE = fso.getFile(RAR_EXE).ShortPath
If Not fso.FileExists(RAR_EXE) Then
WScript.Echo "提示：没有找到 RAR.exe，将退出程序。"
End If
' 获取临时文件位置，以便于保存列表
wso.CurrentDirectory = wso.ExpandenVironmentStrings("%temp%")
file_log = wso.ExpandenVironmentStrings("%temp%") & "\" & fso.GetTempName
Set oExec = wso.Exec("cmd.exe")
oExec.StdIn.WriteLine RAR_EXE & " v """ & file_rar & """>""" & file_log & """"
oExec.StdIn.WriteLine "exit"
errMsg = oExec.StdErr.ReadAll()
stdMsg = oExec.StdOut.ReadAll()
'WScript.Echo "errMsg:" & errMsg & "stdMsg:" & stdMsg
' 分析文件列表，取出对应的因素
Dim bStart, bEnd, strLine, arrLog()
ReDim Preserve arrLog(1,1)
Set rTxt = fso.OpenTextFile(fso.GetFile(file_log).Path, 1)
Do Until rTxt.AtEndOfStream
'逐行读取
strLine = Trim(rTxt.ReadLine())
If strLine=String(79,"-") Then ' 开始、结束标记
If bStart=False Then
bStart = True
nLine = 0
Else
bEnd = True
Exit Do
End If
Else
If bStart=True Then
nSplit = Fix(nLine/2)
ReDim Preserve arrLog(1, nSplit)
nLine = nLine + 1
If nLine Mod 2 <> 0 Then
' 文件路径
WScript.Echo nLine & " Path: " & Trim(strLine)
arrLog(0, nSplit) = Trim(strLine)
ElseIf regEx_test("[\.A-Z]{7}", strLine)=True Then
' 属性
WScript.Echo nLine & " Attr: " & Trim(Join(regEx_execute("[\.A-Z]{7}", strLine), ""))
arrLog(1, nSplit) = Trim(Join(regEx_execute("[\.A-Z]{7}", strLine), ""))
End If
End If
End If
Loop
rTxt.close
' 分析每一个因素
Dim i, nRoot, nFile, nFolder
nRoot = 0
nFile = 0
nFolder = 0
For i = 0 To UBound(arrLog, 2)
' 统计文件夹个数
If InStr(arrLog(1, i), "D") >0 Then nFolder = nFolder + 1
' 统计文件个数
If InStr(arrLog(1, i), "A") >0 Then nFile = nFile + 1
' 统计在根目录下的文件或文件夹个数
If Not InStr(arrLog(0, i), "\") >0 Then nRoot = nRoot + 1
Next
WScript.Echo "该压缩文件含：" & nFolder & "个文件夹，" & nFile & "个文件。"
WScript.Echo "该压缩文件根目录下有" & nRoot & "个文件、或文件夹。"
If nRoot = 1 Then
WScript.Echo "执行1：RAR 直接解压……"
Msgbox "执行1：RAR 直接解压……"
fp = fso.GetFile(file_rar).ParentFolder ' 文件所在的文件夹路径
If Right(fp,1)<>"\" Then fp = fp & "\"
wso.Run """" & RAR_EXE & """ x -r -y """ & file_rar & """ """ & fp & """"
Else
WScript.Echo "执行2：RAR 解压到文件夹……"
Msgbox "执行2：RAR 解压到文件夹……"
fp = fso.GetFile(file_rar).ParentFolder
If Right(fp,1)<>"\" Then fp = fp & "\"
fp = fp & Left(fso.GetFileName(file_rar), Len(fso.GetFileName(file_rar))-Len(fso.GetExtensionName(file_rar))-1)
If Right(fp,1)<>"\" Then fp = fp & "\"
wso.Run """" & RAR_EXE & """ x -r -y """ & file_rar & """ """ & fp & """"
End If
End Sub
' 取得正则表达式搜索结果，返回数组
Function regEx_execute(ByVal sPattern, ByVal str)
Dim regEx, Match, Matches, arrMatchs(), i : i = -1 ' 建立变量。
Set regEx = CreateObject("VBScript.RegExp") ' 建立正则表达式。
regEx.Pattern = sPattern ' 设置模式。
regEx.IgnoreCase = True ' 设置是否区分字符大小写。
regEx.Global = True ' 设置全局可用性。
regEx.MultiLine = True ' 多行匹配模式
Set Matches = regEx.Execute(str) ' 执行搜索。
For Each Match in Matches ' 遍历匹配集合。
If Not Match.Value = "" Then
i = i + 1
ReDim Preserve arrMatchs(i) ' 动态数组：数组随循环而变化
arrMatchs(i) = Match.Value
End If
Next
regEx_execute = arrMatchs
Set Match = Nothing
Set regEx = Nothing
End Function
' 正则表达式测试
Function regEx_test(ByVal sPattern, ByVal str)
Dim regEx, Match, Matches ' 建立变量。
Set regEx = CreateObject("VBScript.RegExp") ' 建立正则表达式。
regEx.Pattern = sPattern ' 设置模式。
regEx.IgnoreCase = True ' 设置是否区分字符大小写。
regEx.Global = True ' 设置全局可用性。
regEx.MultiLine = True ' 多行匹配模式
regEx_test = regEx.Test(str)
Set regEx = Nothing
End Function

复制代码

RAR 3.70 beta 8 版权 (C) 1993-2007 Alexander Roshal 5 五月 2007
已注册给 Mittal Steel Temirtau
压缩文件 d:\1.rar
路径名/注释
尺寸压缩率日期时间属性 CRC 方法版本
-------------------------------------------------------------------------------
1\2\6.txt
0 0 0% 12-07-14 17:12 .....A. 00000000 m0b 2.9
1\3\7\6.txt
0 0 0% 12-07-14 17:12 .....A. 00000000 m0b 2.9
1\4.txt
0 0 0% 12-07-14 17:12 .....A. 00000000 m0b 2.9
1\3\7
0 0 0% 12-07-14 17:12 .D..... 00000000 m0 2.0
1\2
0 0 0% 12-07-14 17:12 .D..... 00000000 m0 2.0
1\3
0 0 0% 12-07-14 17:12 .D..... 00000000 m0 2.0
1
0 0 0% 12-07-14 17:12 .D..... 00000000 m0 2.0
-------------------------------------------------------------------------------
7 0 0 0%

复制代码

已注册给 0
压缩文件: C:\Users\Spring\Downloads\0\第三种情况.rar
详细资料: RAR 4
属性大小压缩率日期时间校验和名称
----------- --------- -------- ----- -------- ----- -------- ----
..A.... 0 0 0% 16-07-14 20:13 00000000 t\1.txt
..A.... 0 0 0% 16-07-14 20:13 00000000 t\2.txt
..A.... 0 0 0% 16-07-14 20:13 00000000 t\3.txt
...D... 0 0 0% 16-07-14 20:14 00000000 t
----------- --------- -------- ----- -------- ----- -------- ----
0 0 0% 4

复制代码

Main
Sub Main
' 以命令行模式运行，可去掉(需要同时去掉WScript.Echo部分)
If InStr(1,WScript.FullName&"|","WScript.exe|",1)>0 Then
Dim oArg, sArgs
For Each oArg In WScript.Arguments
sArgs = sArgs & " """ & oArg & """"
Next
CreateObject("WScript.Shell").Run "CScript.exe //NoLogo """ & _
Wscript.ScriptFullName & """" & sArgs
WScript.Quit(0)
End If
' 获取参数
If WScript.Arguments.Count = 0 Then
WScript.Echo vbCrLf & " --- 错误：没有参数。请拖放一个压缩文件到本程序图标上。" & _
vbCrLf & " --- 程序将在 5 秒后退出 ... "
WScript.Sleep 5000
WScript.Quit(1)
Else
For Each arg In WScript.Arguments
Expand arg
Next
WScript.Echo vbCrLf & " --- 完成。" & _
vbCrLf & " --- 程序将在 5 秒后退出 ... "
WScript.Sleep 5000
WScript.Quit(0)
End If
End Sub
' 使用 7z.exe 智能解压压缩文件
Sub Expand(solid_file)
Dim wso, fso
Set wso = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
' 检测参数
If Not fso.FileExists(solid_file) Then
WScript.Echo vbCrLf & " --- 错误：仅支持文件参数。" & _
vbCrLf & " --- 程序将在 5 秒后退出 ... "
WScript.Sleep 5000
WScript.Quit(2)
End If
' 检查 7z.EXE 是否存在
BinPath = wso.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\7zFM.exe\path")
If Not fso.FileExists(BinPath & "\7zFM.exe") Then
WScript.Echo vbCrLf & " --- 错误：本程序依赖 7-Zip 程序，请安装 7-Zip 后执行本程序。" & _
vbCrLf & " --- 程序将在 5 秒后退出 ... "
WScript.Sleep 5000
WScript.Quit(1)
End If
' 执行 7z.exe 保存结果
WScript.Echo vbCrLf & " --- 正在检查压缩文件 " & vbCrLf & solid_file
wso.CurrentDirectory = wso.ExpandenVironmentStrings("%temp%")
file_log = wso.ExpandenVironmentStrings("%temp%") & "\" & fso.GetTempName
file_log = wso.ExpandenVironmentStrings("%temp%\7z-check.log")
Set oExec = wso.Exec("cmd.exe")
oExec.StdIn.WriteLine """" & BinPath & "\7z.exe""" & " l """ & solid_file & """>""" & file_log & """"
oExec.StdIn.WriteLine "exit"
errMsg = oExec.StdErr.ReadAll()
stdMsg = oExec.StdOut.ReadAll()
'WScript.Echo "errMsg:" & errMsg & "stdMsg:" & stdMsg
' 分析文件列表，取出对应的因素
Dim oTxt, bStart, bEnd, strLine, nLine, nRootFile, nRootFolder, nFile, nFolder
nLine=0 : nRootFile=0 : nRootFolder=0 : nFile=0 : nFolder=0
Set oTxt = fso.OpenTextFile(fso.GetFile(file_log).Path, 1)
Do Until oTxt.AtEndOfStream
'逐行读取
strLine = Trim(oTxt.ReadLine()) ' 开始、结束标记(---)
If strLine = "------------------- ----- ------------ ------------ ------------------------" Then
If bStart=False Then
bStart = True
Else
bEnd = True : Exit Do
End If
Else
If bStart = True Then
nLine = nLine + 1
' 分析每一个元素
If regEx_test("[\.A-Z]{5}", strLine)=True Then
' 统计在根目录下的文件/文件夹个数
strAttr = Trim(Join(regEx_execute("[\.A-Z]{5}", strLine), ""))
If Not InStr(strLine, "\") > 0 Then
If InStr(strAttr, "A") > 0 Then nRootFile = nRootFile + 1
If InStr(strAttr, "D") > 0 Then nRootFolder = nRootFolder + 1
End If
' 统计文件/文件夹个数
If InStr(strAttr, "A") >0 Then nFile = nFile + 1
If InStr(strAttr, "D") >0 Then nFolder = nFolder + 1
WScript.Echo "[" & nLine & "]" & vbTab & strLine
End If
End If
End If
Loop
oTxt.close
WScript.Echo vbCrLf & "该压缩文件含：" & nFile & " 个文件，" & nFolder & " 个文件夹。" & _
vbCrLf & "该压缩文件根目录下有：" & nRootFile & " 个文件，" & nRootFolder & " 个文件夹。"
' 判断解压位置
fn = Left(fso.GetFileName(solid_file), Len(fso.GetFileName(solid_file))-Len(fso.GetExtensionName(solid_file))-1)
fp = fso.GetFile(solid_file).ParentFolder ' 文件所在的文件夹路径
' 根目录下只有一个文件或文件夹时直接解压，其他情况建立文件夹后解压。
If nRootFile + nRootFolder <= 1 Then
WScript.Echo vbCrLf & " --- 执行1：直接解压 ... "
ElseIf (nRootFile > 1) Or (nRootFile + nRootFolder > 1) Then
WScript.Echo vbCrLf & " --- 执行2：解压到文件夹 ... "
fp = fp & "\" & fn
Else
WScript.Echo vbCrLf & " --- 执行2：解压到文件夹 ..."
fp = fp & "\" & fn
End If
' 执行解压
wso.Run """" & BinPath & "\7zG.exe"" x """ & solid_file & """ -o""" & fp & """", 1, True
Set fso = Nothing
Set wso = Nothing
End Sub
' 取得正则表达式搜索结果，返回数组
Function regEx_execute(ByVal sPattern, ByVal str)
Dim objItem, arrMatchs(), i : i = -1
With CreateObject("VBScript.RegExp")
.Pattern=sPattern : .IgnoreCase=True
.Global=True : .MultiLine=True
For Each objItem In .Execute(str)
If Not objItem.Value = "" Then
i=i+1 : ReDim Preserve arrMatchs(i)
arrMatchs(i) = objItem.Value
End If
Next
End With
regEx_execute = arrMatchs
End Function
' 正则表达式测试
Function regEx_test(ByVal sPattern, ByVal str)
With CreateObject("VBScript.RegExp")
.Pattern=sPattern : .IgnoreCase=True
.Global=True : .MultiLine=True
regEx_test = .Test(str)
End With
End Function

复制代码