自动抽取批量rar文件中word文档的脚本（更新版本）

上学期我发过日志介绍了一个脚本程序，因为我上的《大学计算机文化二》课中学生上交的都是一个rar压缩包，里面有各种实验文件，包括实验报告，而最后我查看完内容后要将评分和评语写入实验报告，因此需要统一的把各自学生包中的实验报告抽取出来，集中批改。

       通过上学期的批改实践，我发现了上个版本中的一些错误，并进行了bug修正，修正版本如下：

0）由于脚本只能找出doc文档，所有提示符里去掉了要求输入扩展名，最好用“*实验*”找所有文件名中包含实验两字的文档，不要加具体实验号，因为有些学生可能在这次课交上次课的实验报告。当然如果你能看懂这个脚本的话，自己修改成抽取其他类型文件也是容易的。

1）上一版本，压缩文件所在文件夹名，路径名和压缩文件名不能带有空格或在桌面，这一版本已修正。

 

2）由于脚本的内部运行机制，上一版本在压缩文件所在目录同时有其他doc文档时，会出错，这一版本提前将这些文件放进了创建doc子文件夹，然后解压出来的目标文档也在doc子文件夹里面。这样也带出了个程序的附带功能，就是能将本目录下的文档进行分类放入子目录，比如找出本文件夹下所有的名字中带“荷塘月色”的文档。

 

3）这一版本增加了一功能，在发现有学生的压缩包里没有目标文档时，会将该压缩包复制到程序创建的notfound子目录下，便于我们事后检查，这些学生为什么没交实验报告，还是命名不规范，便于告知这些学生。

 

4）文档最后增加了如下图的统计信息

要应对的是如下图的，恰好学生的实验练习文档名也带有“实验”两字的情况，比如上图的39个压缩文件里找到了71个目标文档显然是不对的。

 

5）上一版本没有递归查找很深的压缩包子目录里的目标文档，这一版本做了修正。

 

6）可能一个压缩包里学生交1个以上的重名目标文档，这次对这些文档自动做了重命名，比如第二个重复文档名带“（1）”表示。

 

程序已经上传到http://e.ys168.com/?wucccsk  下的“vbs和vba脚本”目录下，双击vbs脚本即可运行，也可以新建记事本，然后将下列源代码复制到文档中，选择另存，文件类型选择“所有文件”，文件名的扩展名为VBS。希望大家用的愉快，减轻工作负担，最后附上源码清单：

 

filterstr=inputbox("请输入要解压的word文件，如 * 或者 *实验* 等",,"*实验*")
if filterstr="" then WScript.Quit
filterstr=filterstr & ".doc"
nofoundstr=""
rarcount=0
doccount=0
Set WshShell = WScript.CreateObject("WScript.Shell")
rarpath=WshShell.Regread("HKLM/Software/Microsoft/Windows/CurrentVersion/Uninstall/Winrar archiver/UninstallString")
lenstr=Instr(lcase(rarpath),"uninstall.exe")
rarpath=Left(rarpath,lenstr-1) & "unrar.exe"
rarpath=chr(34) & rarpath & chr(34)
Set FSO = CreateObject("Scripting.FileSystemObject")
CurrentDirectory=WshShell.CurrentDirectory
Set myFolder=FSO.GetFolder(CurrentDirectory)
Set myfiles=myFolder.Files
myfilename=mid(wscript.scriptfullname,len(CurrentDirectory)+2)
If fso.FolderExists(CurrentDirectory & "/doc") Then
   fso.DeleteFolder (CurrentDirectory & "/doc")
End If
fso.CreateFolder CurrentDirectory & "/doc"
For Each myfile in myfiles
         if Instr(myfile.name,".doc")<>0 then
                   OldName=CurrentDirectory & "/" &  myfile.name
                   if Instr(myfile.name,"实验")<>0 then
                        NewName = CurrentDirectory & "/doc/" & myfile.name
                   else
                        If not fso.FolderExists(CurrentDirectory & "/otherdoc") Then
                             fso.CreateFolder CurrentDirectory & "/otherdoc"
                        End If   
                        NewName = CurrentDirectory & "/otherdoc/" & myfile.name
                   end if
                   fso.movefile oldname,newname
         end if
next
newname=""
oldname=""
For Each myfile in myfiles
        if myfile.name<>myfilename and instr(myfile.name,".rar")<>0 then
         exestr=rarpath & " e -o+ -or -r -n"& filterstr & " """& CurrentDirectory & "/" & myfile.name & """"
         Wshshell.run  exestr,0,true
         Set submyfiles=myFolder.Files
         found=false
         For Each submyfile in submyfiles
           if Instr(submyfile,".doc") then
           OldName = CurrentDirectory &"/"& submyfile.name
           tempstr=left(myfile.name,len(myfile.name)-4)
           NewName = CurrentDirectory &"/doc/"& tempstr &"-"&  submyfile.name
           fso.movefile OldName,newname
           found=true
           doccount=doccount+1
           end if
         next
           if found then rarcount=rarcount+1
           if not found then
                if nofoundstr="" then
                     If fso.FolderExists(CurrentDirectory & "/notfound") Then
                         fso.DeleteFolder (CurrentDirectory & "/notfound")
                     End If
                     fso.CreateFolder CurrentDirectory & "/notfound"
                end if    
                fso.copyfile CurrentDirectory & "/" & myfile.name,CurrentDirectory & "/notfound/" & myfile.name
                nofoundstr=nofoundstr & " , " & myfile.name
           end if
         set submyfiles=nothing
        end if
Next
if nofoundstr<>"" then
            msgbox  nofoundstr & "中没有发现目标文档"
end if
set wshell=nothing
set fso=nothing
set myfolder=nothing
set myfiles=nothing
msgbox "从"& rarcount & "个压缩文件中找到了" & doccount &"个目标文档！"