VBS怎样根据word内容标题自动重命名word文件名？

yhcbird

 
set fso=createobject("scripting.filesystemobject")
set folder=fso.getfolder(".")
set files=folder.files
for each file in files 
        if lcase(right(file,3))="doc"  then
                a=1
                Set objWord = CreateObject("Word.Application")
                Set objDoc = objWord.Documents.Open(cstr(file))
                wjm=objDoc.Paragraphs(1).Range
                objWord.Quit
        if file.name <> replace(wjm,vbcr,"") & ".doc" then createobject("wscript.shell").run "cmd /c ren " & chr(34) & file.name  & chr(34) & " " & chr(34) & wjm & ".doc"  & chr(34),0
        end if
next
if a=1 then
        msgbox "操作成功!",4096,"提示"
else
        msgbox "对不起，没有在【" & folder & "】下找到WORD文件",4096,"提示"
end if 
复制代码

这是一段根据word内容标题自动为word重命名的代码。这段代码是从网上复制过来的
刚把这快代码发在批处理版块了。。这里想请各位帮忙看下这段代码怎么改进比较。可以减少错误发生率。。
因为在执行的时候会第几行错误。。。貌似假如文件内容标题在第二行，第一行是空行的，就不会自动搜索第2行的标题，望高手看个端倪。。

[ 本帖最后由 yhcbird 于 2011-1-26 17:21 编辑 ]

broly

哦？我测试是没有问题的。出错提示什么？

yhcbird

辛苦了。测试下。没有成功。。。

broly

刚开完盘车，然后看了下这题，写了代码如下：

Dim fso,fc,f,strName
Set fso = CreateObject("scripting.filesystemobject")
Set fc=fso.GetFolder(".").Files
For Each f In fc
  If LCase(fso.GetExtensionName(f))="doc" Then
    strName=GetFileName(f.Path)
  End If 
  f.Name=strName & ".doc"
  Exit For 
Next
Set fso=Nothing 
Function GetFileName(FilePath)
  Dim i,objWord,Doc
  Set objWord=CreateObject("word.application")
  Set Doc=objWord.Documents.Open(FilePath)
  For i=1 To Doc.Paragraphs.Count
    If Replace(Doc.Paragraphs(i).Range," ","")<>vbCr Then 
      GetFileName=Replace(Doc.Paragraphs(i).Range,vbCr,"")
      Exit For
    End If 
  Next
  objWord.Quit
  Set objWord=Nothing 
End Function
复制代码

这个代码有点还不是很到位的，就是，如果标题含有特殊字符 \ / * | 之类的，那必须要过滤。其实用replace语句可以解决的，这里我偷下懒就不写了，睡觉，晚安~

broly

Word.Application对象没用过

待我研究一番先