vbs批量自动判断文件类型,修改扩展名

有一同事昨天发来救命的邮件，说她的一个工作文件夹下的2000多个文件都变成了file0001.chk,file0002.chk......，那可是她几年的心血，如无法还原会抓狂的。     分析原因估计是病毒或其他原因造成FAT错误，电脑检查磁盘时进行修复，就成这个样子了，试着把几个文件扩展名改为DOC或XLS，发现文件还是可以打开的，看来部分文件还是可以拯救的，只是2000个文件，如果一个一个试，岂不要等到地老天荒？况且即使扩展名改好了，文件名都是file???的格式，以后谁知道哪个文件是什么内容，想想还是写个小脚本来干这活吧。   思路是：建一个空的目标文件夹，然后读取源文件夹的每个文件，判断文件类型，读取文件标题，如文件标题不为空，则用文件标题作为文件名，最后把源文件用新文件名复制到目标文件夹。具体代码如下，大家如有更好的办法要告诉我哦。'filename: repair.vbsDim arrHeaders(34)
'源目录
var_source_path="d:\test"'处理后目录
var_destination_path="d:\ok"Set objShell = CreateObject("Shell.Application")
set fso=wscript.createobject("scripting.FileSystemObject")
Set objFolder = objShell.Namespace(var_source_path)'加一个计数器，用在修改后的文件名后，以防止两个文件标题相同而导致文件名相同的情况。
g_count=1
For Each strFileName in objFolder.Items
    For i = 0 to 33
       arrHeaders(i) = objFolder.GetDetailsOf(objFolder.Items, i)
       if arrHeaders(i)="名称" then
         '获取文件名
         var_filename=trim(objFolder.GetDetailsOf(strFileName, i) )
       end if
       if arrHeaders(i)="标题" then
         '获取文件中的标题属性，如为WORD或POWERPOINT一般都有标题
         var_filetitle=objFolder.GetDetailsOf(strFileName, i)
       end if
    Next
    var_binary=ReadBinaryFile(var_source_path & "\" & var_filename)
   
    '由于可能用标题作为文件名，要把标题中不能做为文件名的字符去掉。
    var_filetitle=replace(var_filetitle,":","")
    var_filetitle=replace(var_filetitle,"/","")
    var_filetitle=replace(var_filetitle,"\","")
    var_filetitle=replace(var_filetitle,"*","")
    var_filetitle=replace(var_filetitle,"?","")
    var_filetitle=replace(var_filetitle,"""","")
    var_filetitle=replace(var_filetitle,"<","")
    var_filetitle=replace(var_filetitle,">","")
    var_filetitle=replace(var_filetitle,"|","")
   
    '如果标题为空，则文件名保持不变，否则用标题作为文件名
    if len(trim(var_filetitle))=0 then
       var_newfile=left(var_filename,instr(var_filename,".")-1)
    else
         var_newfile=var_filetitle & right(10000+g_count,4)
    end if
   
    '判断文件的类别是否为word,excel或powerpoint，如是则复制到目标文件夹的文件扩展名改为doc,xls和ppt,如非这三种类型，文件名不变。  
    if ascb(midb(var_binary,1,1))=208 and ascb(midb(var_binary,2,1))=207 and ascb(midb(var_binary,3,1))=17 and ascb(midb(var_binary,4,1))=224 and ascb(midb(var_binary,513,1))=236 and ascb(midb(var_binary,514,1))=165 then
       fso.copyfile var_source_path & "\" & var_filename,var_destination_path & "\" & var_newfile & ".doc"
    else
     if ascb(midb(var_binary,1,1))=208 and ascb(midb(var_binary,2,1))=207 and ascb(midb(var_binary,3,1))=17 and ascb(midb(var_binary,4,1))=224 and ascb(midb(var_binary,513,1))=160 and ascb(midb(var_binary,514,1))=70 then
        fso.copyfile var_source_path & "\" & var_filename,var_destination_path & "\" & var_newfile & ".ppt"
     else
      if ascb(midb(var_binary,1,1))=208 and ascb(midb(var_binary,2,1))=207 and ascb(midb(var_binary,3,1))=17 and ascb(midb(var_binary,4,1))=224 and ascb(midb(var_binary,513,1))=9 and ascb(midb(var_binary,514,1))=8 then
         fso.copyfile var_source_path & "\" & var_filename,var_destination_path & "\" & var_newfile & ".xls"
      else
         fso.copyfile var_source_path & "\" & var_filename,var_destination_path & "\" & var_filename
      end if
     end if
    end if
    g_count=g_count+1
Next
wscript.echo "文件处理完毕, 请到"&var_destination_path&"目录下查看处理后的文件"
Set objShell = nothing
set fso=nothing
Set objFolder = nothingFunction ReadBinaryFile(FileName)
Const adTypeBinary = 1Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")'设定为二进制类型
BinaryStream.Type = adTypeBinaryBinaryStream.OpenBinaryStream.LoadFromFile FileNameReadBinaryFile = BinaryStream.ReadSet BinaryStream=nothingEnd Function