VBS 有关提取WORD第二行的文字为文件名的方式

word

完整代码: 1、用记事本新建一个文本文件，把它保存为“批量重命名.vbs”(注意不要弄成了“批量重命名.vbs.txt”，也就是要确保其扩展名为360问答“.vbs”); 2、把下列代码粘贴到这个VBS文件中: Option Explicit Const g_strRootPath = c:\Temp\docs\word\ToRename\ ' 指定存放所有文件的目录，可以有子目录 Const g_nTitleMaxLen = 16 ' 指定获取文档里面第一段中的前多少个字符来作为文件名 Const g_Line = 2 ' 指定获取文档里面第一段中的第2行 Call MAIn ' 主函数入口 Sub MAIn() Dim fso, oFolder, oWo单罗充水味析项义京抓rdApp Set owordApp = CreateObject(word.Application) Set fso = CreateObject(Scripting.FileSystemObject) Set oFolder = fso.GetFolder(g_strRootPath) RenameDocFilesUnderFolder owordApp, fso, oFolder owordApp.Quit Set owordApp = Nothing MsgBox 完成! End Sub ' 重命名指定文件夹(递归)下面的所有word文件，按照文件里面的第一句可见的文字命名 屋酒德游燃心计利Sub RenameDocFilesUnderFolder(owordApp, fso, oFolder) Dim oSubFolder, oFile, oDoc Dim strTitle, strFileName For Each oSubFolder In oFolder.SubFolders RenameDocFilesUnderFolder owordApp, fso, oSubFolder Next For Each oFile In oFolder.Files Set oDoc = owordApp.***.Open(oFile.Path) strTitle = GetFirstVisibleTextConte黄很差美修太汉杀nt(oDoc) oDoc.Close Set oDoc = Nothing If 星的Len(strTitle) 0 Then strFileName = fso.Build义础重图执飞要Path(fso.GetParentFolderName(oFile.Path), strTitle & . & fso.GetExtensionName(oFile.Path)) strFileName = GetUniqueFileName(fso, strFileName) fso.MoveFile oFile.Path, strFileName End If Next End Sub ' 获取指定文档第二行可见文字 Function GetFirstVisibleTextContent(oDoc) Dim oP点滑师常定我蒸秋片aragraph Dim strContent Dim i For Each oParagraph In oDoc.Paragraphs strContent = GetSafeFileName(oParagraph.Range.Text) If Len(strContent) 0 Then i = i + 1 If i = g_Line Then GetFirstVisibleTextContent = strContent Exit Function End If End If Next GetFirstVisibleTextContent = End Function ' 过滤文件名里面的无效字符 Function GetSafeFileName(strFileName) Dim arrUnsafeCharacters, strUnsafeChar Dim nIndex arrUnsafeCharacters = Array(\, /, :, *, ?, , , , |) For nIndex = 0 To &H2F strFileName = Replace(strFileName, Chr(nIndex), ) Next For Each strUnsafeChar In arrUnsafeCharacters strFileName = Replace(strFileName, strUnsafeChar, ) Next GetSafeFileName = Left(Trim(strFileName), g_nTitleMaxLen) End Function ' 获取不重复的文件名，如果有重名则在文件名后面附加“_1”、“_2”…… Function GetUniqueFileName(fso, strFullName) Dim strParentFolder, strBaseName, strExtensionName Dim nIndex If Not fso.FileExists(strFullName) Then GetUniqueFileName = strFullName Exit Function End If strParentFolder = fso.GetParentFolderName(strFullName) strBaseName = fso.GetBaseName(strFullName) strExtensionName = fso.GetExtensionName(strFullName) nIndex = 0 While fso.FileExists(strFullName) nIndex = nIndex + 1 strFullName = fso.BuildPath(strParentFolder, strBaseName & _ & nIndex & . & strExtensionName) Wend GetUniqueFileName = strFullName End Function 3、修改代码中开始部分的三个设置，即:存放等待重命名的word文件的根目录，第几行，以及获取文档第一段内容时最多保留多少个字符。 4、保存这个VBS文件，在资源管理器中双击运行它，直到看见“完成”! 5、检查所有文件是否已自动重命名。 注意:如果有两个以上的文档依据其内容提取出来的文字相同，则会自动在文件名后面附加“_1”、“_2”、“_3”……。 如果有什么问题，请和我联系。