Board logo

标题: [问题求助] [已解决]VBS提取指定内容重命名怎么写? [打印本页]

作者: xp3000    时间: 2015-6-24 08:53     标题: [已解决]VBS提取指定内容重命名怎么写?

本帖最后由 xp3000 于 2015-6-25 16:06 编辑

比如有大量XHTML,在文件夹里面建立个VBS运行,提取出<title>到</title>之间的字符串给文件重命名
原文件是003.XHTML,重命名文件为第3章 小恶魔公主.XHTML
  1. <?xml version="1.0" encoding="UTF-8" standalone="no" ?>
  2. <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
  3. <html xmlns="http://www.w3.org/1999/xhtml">
  4. <head>
  5.     <title>第3章 小恶魔公主</title>
  6.     <meta name="Adept.resource"/>
  7.     <link href="../Styles/main.css" rel="stylesheet" type="text/css"/>
  8. <style type="text/css">
  9. body{font-size:18px}
  10. </style>
  11. </head>
  12. <body>
  13. ......
复制代码

作者: yu2n    时间: 2015-6-24 13:34

本帖最后由 yu2n 于 2015-6-25 08:36 编辑

VBS 批量修改HTML文件名为title值 By Yu2n.vbs
  1. ' VBS 批量修改XHTML文件名为title值 By Yu2n.vbs
  2. Option Explicit
  3. '指定文件类型、文件编码
  4. Const sFileType = ".XHTML|.html|.htm"
  5. Const sCharset = "utf-8"
  6. Call CommandMode()
  7. Main
  8. Sub Main()
  9.   
  10.   '选择文件夹
  11.   Dim strFolder, arrPath, strPath, nCount, i
  12.   strFolder = BrowseForFolder("请选择要重命名的 " & sFileType & " 文件所在目录:")
  13.   If strFolder = "" Then
  14.     WScript.Echo vbCrLf & " --- 错误:没有选择文件夹。程序即将退出 ..." & vbCrLf
  15.     Exit Sub
  16.   End If
  17.   
  18.   '扫描文件夹
  19.   arrPath = ScanFolder(strFolder)
  20.   
  21.   '统计个数,用于显示进度
  22.   For Each strPath In arrPath
  23.     If InStr(1,"|"&sFileType&"|","|."&GetExtensionName(strPath)&"|",vbTextCompare)>0 Then
  24.       nCount=nCount+1
  25.     End If
  26.   Next
  27.   
  28.   '执行批量处理
  29.   Dim dtStart, objWord : dtStart=Now()  '计时
  30.   For Each strPath In arrPath
  31.     If InStr(1,"|"&sFileType&"|","|."&GetExtensionName(strPath)&"|",vbTextCompare)>0 Then
  32.       i=i+1  '计数
  33.       WScript.Echo "[" & i & "/" & nCount & "]" & strPath  ' 显示进度
  34.       Call ReNameByTitle(strPath)                          ' 执行替换
  35.     End If
  36.   Next
  37.   
  38.   '显示结果
  39.   WScript.Echo vbCrLf & " --- 完成。总计 " & nCount & " 个文档完成操作,耗时 " _
  40.     & DateDiff("s",dtStart,Now()) & " 秒。" & vbCrLf
  41.    
  42. End Sub
  43. '重命名xml文件(依据title值)
  44. Function ReNameByTitle(ByVal sFile)
  45.   ReNameByTitle = False
  46.   Dim fso, sFp, sFx, sFn, sFf
  47.   Set fso = CreateObject("Scripting.FileSystemObject")
  48.   sFp = fso.GetFile(sFile).ParentFolder
  49.   sFx = fso.GetExtensionName(sFile)
  50.   sFn = GetHtmlTitle(sFile)
  51.   sFf = sFp & "\" & sFn & "." & sFx
  52.   If sFn = "" Then Exit Function
  53.   fso.GetFile(sFile).Move sFf
  54.   ReNameByTitle = fso.FileExists(sFf)
  55. End Function
  56. '获取xml文件title值
  57. Function GetHtmlTitle(ByVal sFile)
  58.   Dim oHtml, sHtml, oTitle
  59.   Set oHtml = CreateObject("htmlfile")
  60.   oHtml.DesignMode = "on"    ' 开启编辑模式
  61.   sHtml = Pfile(sFile, sCharset, "")   'sHtml = Pfile(sFile, "utf-8", "")
  62.   oHtml.Write sHtml          ' 写入数据
  63.   Set oTitle = oHtml.getElementsByTagName("title")
  64.   If Not oTitle Is Nothing Then GetHtmlTitle=oTitle(0).innerHTML
  65. End Function
  66. '获取文件拓展名
  67. Function GetExtensionName(ByVal sPath)
  68.   Dim sFf, sFnx, sFx
  69.   sFf = Trim(sPath)
  70.   If sFf <> "" Then sFnx = Split(sFf, "\")(UBound(Split(sFf, "\")))
  71.   If sFnx <> "" Then sFx = Split(sFnx, ".")(UBound(Split(sFnx, ".")))
  72.   GetExtensionName = sFx
  73. End Function
  74. ' 浏览文件夹
  75. Function BrowseForFolder(ByVal strTips)
  76.   Dim objFolder
  77.   Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)
  78.   If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path
  79. End Function
  80. ' 获取文件夹所有文件夹、文件列表(数组)
  81. Function ScanFolder(ByVal strFolder)
  82.   If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
  83.   Dim arrList() : ReDim Preserve arrList(0) : arrList(0) = strFolder
  84.   Call DO_SCAN_FOLDER(arrList, strFolder) : ScanFolder = ArraySort(arrList)
  85. End Function
  86. Function DO_SCAN_FOLDER(ByRef arrList, ByVal strFolder)
  87.   On Error Resume Next
  88.   Dim fso, objItems, objFile, objFolder
  89.   Set fso = CreateObject("Scripting.FileSystemObject")
  90.   Set objItems = fso.GetFolder(strFolder)
  91.   If (Not fso.FolderExists(strFolder)) Then Exit Function
  92.   For Each objFile In objItems.Files
  93.     ReDim Preserve arrList(UBound(arrList) + 1)
  94.     arrList(UBound(arrList)) = objFile.Path
  95.   Next
  96.   For Each objFolder In objItems.subfolders
  97.     ReDim Preserve arrList(UBound(arrList) + 1)
  98.     arrList(UBound(arrList)) = objFolder.Path & "\"
  99.     Call DO_SCAN_FOLDER(arrList, objFolder.Path & "\")
  100.   Next
  101. End Function
  102. Function ArraySort(ByVal arr)
  103.   Dim i, j, tmp
  104.   For i=1 To UBound(arr)
  105.     For j=i To 1 Step -1
  106.       If CStr(arr(j))<CStr(arr(j-1)) Then
  107.         tmp=arr(j) : arr(j)=arr(j-1) : arr(j-1)=tmp
  108.       End If
  109.     Next
  110.   Next
  111.   ArraySort = arr
  112. End Function
  113. 'Pfile()
  114. '对文本指定编码进行读写操作
  115. '指定编码写入                 Call Pfile("C:\1.txt", "utf-8", strText)
  116. '指定编码读取 strText = ""  : Call Pfile("C:\1.txt", "utf-8", strText)
  117. 'FileCode: ANSI/UTF-8/Unicode/ULE/UBE/GB2312/GBK/Big5/日文EUC-JP/韩文EUC-KR
  118. Function Pfile(ByVal sFile, ByVal FileCode, ByRef sText)
  119.   With CreateObject("ADODB.Stream")
  120.     .Type=2 : .Mode=3 : .Charset=FileCode : .Open
  121.     If sText="" Then
  122.       .LoadFromFile sFile : sText=.ReadText : Pfile=sText
  123.     Else
  124.       .WriteText sText : .SaveToFile sFile, 2
  125.     End If
  126.     .Close
  127.   End With
  128. End Function
  129. 'Command Mode
  130. Sub CommandMode()
  131.   If InStr(1, WScript.FullName, "\cscript.exe", vbTextCompare) > 0 Then Exit Sub
  132.   CreateObject("WScript.Shell").Run "cmd /c title " & WScript.ScriptName & _
  133.     " & cscript //nologo """ & WScript.ScriptFullName & """ & pause", 1, False
  134.   WScript.Quit(0)
  135. End Sub
复制代码

作者: xp3000    时间: 2015-6-24 17:06

辛苦了,好多代码,不过不知道为什么我这里没成功,ANSI和UTF-8和Unicode都试了,文件是UTF-8的
作者: yu2n    时间: 2015-6-24 17:19

回复 3# xp3000

错将xhtml看成了xml。
已改正更新。

不过注释这么多了,就是希望你自己也能改了。
作者: xp3000    时间: 2015-6-25 06:41

谢谢,这个能用,麻烦下把HTML和HTM格式的支持也添加下吧
作者: yu2n    时间: 2015-6-25 08:01

回复 5# xp3000

修改第 10 行即可。


如 html 为:
  1.   Const sFileType = ".HTML"
复制代码
htm 为
  1.   Const sFileType = ".HTM"
复制代码

作者: xp3000    时间: 2015-6-25 08:10

代码怎样同时支持三种格式?
作者: yu2n    时间: 2015-6-25 08:26

回复 7# xp3000

已更新。支持 .XHTML|.html|.htm ,更多的格式,自己添加。
作者: xp3000    时间: 2015-6-25 08:44

谢谢很强大




欢迎光临 批处理之家 (http://bbs.bathome.net/) Powered by Discuz! 7.2