[新手上路]批处理新手入门导读[视频教程]批处理基础视频教程[视频教程]VBS基础视频教程[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动[批处理精品]CMD命令50条不能说的秘密[在线下载]第三方命令行工具[在线帮助]VBScript / JScript 在线参考
返回列表 发帖
xp3000

Rank: 5Rank: 5

帖子
441 
积分
618 
技术
37  
捐助
0  
注册时间
2013-4-25 
1楼 跳转到 » 倒序看帖
打印
tT
发表于 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. ......
复制代码
1

评分人数

    • Batcher: 感谢给帖子标题标注[已解决]字样PB + 2
收藏 分享

yu2n

Rank: 5Rank: 5

帖子
715 
积分
1298 
技术
151  
捐助
0  
注册时间
2012-11-1 
2楼
发表于 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. '指定文件类型、文件编码

  5. Const sFileType = ".XHTML|.html|.htm"

  6. Const sCharset = "utf-8"

  7. 

  8. Call CommandMode()

  9. 

  10. Main

  11. Sub Main()

  12.   

  13.   '选择文件夹

  14.   Dim strFolder, arrPath, strPath, nCount, i

  15.   strFolder = BrowseForFolder("请选择要重命名的 " & sFileType & " 文件所在目录：")

  16.   If strFolder = "" Then

  17.     WScript.Echo vbCrLf & " --- 错误：没有选择文件夹。程序即将退出 ..." & vbCrLf

  18.     Exit Sub

  19.   End If

  20.   

  21.   '扫描文件夹

  22.   arrPath = ScanFolder(strFolder)

  23.   

  24.   '统计个数，用于显示进度

  25.   For Each strPath In arrPath

  26.     If InStr(1,"|"&sFileType&"|","|."&GetExtensionName(strPath)&"|",vbTextCompare)>0 Then

  27.       nCount=nCount+1

  28.     End If

  29.   Next

  30.   

  31.   '执行批量处理

  32.   Dim dtStart, objWord : dtStart=Now()  '计时

  33.   For Each strPath In arrPath

  34.     If InStr(1,"|"&sFileType&"|","|."&GetExtensionName(strPath)&"|",vbTextCompare)>0 Then

  35.       i=i+1  '计数

  36.       WScript.Echo "[" & i & "/" & nCount & "]" & strPath  ' 显示进度

  37.       Call ReNameByTitle(strPath)                          ' 执行替换

  38.     End If

  39.   Next

  40.   

  41.   '显示结果

  42.   WScript.Echo vbCrLf & " --- 完成。总计 " & nCount & " 个文档完成操作，耗时 " _

  43.     & DateDiff("s",dtStart,Now()) & " 秒。" & vbCrLf

  44.     

  45. End Sub

  46. 

  47. '重命名xml文件（依据title值）

  48. Function ReNameByTitle(ByVal sFile)

  49.   ReNameByTitle = False

  50.   Dim fso, sFp, sFx, sFn, sFf

  51.   Set fso = CreateObject("Scripting.FileSystemObject")

  52.   sFp = fso.GetFile(sFile).ParentFolder

  53.   sFx = fso.GetExtensionName(sFile)

  54.   sFn = GetHtmlTitle(sFile)

  55.   sFf = sFp & "\" & sFn & "." & sFx

  56.   If sFn = "" Then Exit Function

  57.   fso.GetFile(sFile).Move sFf

  58.   ReNameByTitle = fso.FileExists(sFf)

  59. End Function

  60. 

  61. '获取xml文件title值

  62. Function GetHtmlTitle(ByVal sFile)

  63.   Dim oHtml, sHtml, oTitle

  64.   Set oHtml = CreateObject("htmlfile")

  65.   oHtml.DesignMode = "on"    ' 开启编辑模式

  66.   sHtml = Pfile(sFile, sCharset, "")   'sHtml = Pfile(sFile, "utf-8", "")

  67.   oHtml.Write sHtml          ' 写入数据

  68.   Set oTitle = oHtml.getElementsByTagName("title")

  69.   If Not oTitle Is Nothing Then GetHtmlTitle=oTitle(0).innerHTML

  70. End Function

  71. 

  72. '获取文件拓展名

  73. Function GetExtensionName(ByVal sPath)

  74.   Dim sFf, sFnx, sFx

  75.   sFf = Trim(sPath)

  76.   If sFf <> "" Then sFnx = Split(sFf, "\")(UBound(Split(sFf, "\")))

  77.   If sFnx <> "" Then sFx = Split(sFnx, ".")(UBound(Split(sFnx, ".")))

  78.   GetExtensionName = sFx

  79. End Function

  80. 

  81. ' 浏览文件夹

  82. Function BrowseForFolder(ByVal strTips)

  83.   Dim objFolder

  84.   Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)

  85.   If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path

  86. End Function

  87. 

  88. ' 获取文件夹所有文件夹、文件列表(数组)

  89. Function ScanFolder(ByVal strFolder)

  90.   If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"

  91.   Dim arrList() : ReDim Preserve arrList(0) : arrList(0) = strFolder

  92.   Call DO_SCAN_FOLDER(arrList, strFolder) : ScanFolder = ArraySort(arrList)

  93. End Function

  94. Function DO_SCAN_FOLDER(ByRef arrList, ByVal strFolder)

  95.   On Error Resume Next

  96.   Dim fso, objItems, objFile, objFolder

  97.   Set fso = CreateObject("Scripting.FileSystemObject")

  98.   Set objItems = fso.GetFolder(strFolder)

  99.   If (Not fso.FolderExists(strFolder)) Then Exit Function

  100.   For Each objFile In objItems.Files

  101.     ReDim Preserve arrList(UBound(arrList) + 1)

  102.     arrList(UBound(arrList)) = objFile.Path

  103.   Next

  104.   For Each objFolder In objItems.subfolders

  105.     ReDim Preserve arrList(UBound(arrList) + 1)

  106.     arrList(UBound(arrList)) = objFolder.Path & "\"

  107.     Call DO_SCAN_FOLDER(arrList, objFolder.Path & "\")

  108.   Next

  109. End Function

  110. Function ArraySort(ByVal arr)

  111.   Dim i, j, tmp

  112.   For i=1 To UBound(arr)

  113.     For j=i To 1 Step -1

  114.       If CStr(arr(j))<CStr(arr(j-1)) Then

  115.         tmp=arr(j) : arr(j)=arr(j-1) : arr(j-1)=tmp

  116.       End If

  117.     Next

  118.   Next

  119.   ArraySort = arr

  120. End Function

  121. 

  122. 'Pfile()

  123. '对文本指定编码进行读写操作

  124. '指定编码写入                 Call Pfile("C:\1.txt", "utf-8", strText)

  125. '指定编码读取 strText = ""  : Call Pfile("C:\1.txt", "utf-8", strText)

  126. 'FileCode: ANSI/UTF-8/Unicode/ULE/UBE/GB2312/GBK/Big5/日文EUC-JP/韩文EUC-KR

  127. Function Pfile(ByVal sFile, ByVal FileCode, ByRef sText)

  128.   With CreateObject("ADODB.Stream")

  129.     .Type=2 : .Mode=3 : .Charset=FileCode : .Open

  130.     If sText="" Then

  131.       .LoadFromFile sFile : sText=.ReadText : Pfile=sText

  132.     Else

  133.       .WriteText sText : .SaveToFile sFile, 2			

  134.     End If

  135.     .Close

  136.   End With

  137. End Function

  138. 

  139. 'Command Mode

  140. Sub CommandMode()

  141.   If InStr(1, WScript.FullName, "\cscript.exe", vbTextCompare) > 0 Then Exit Sub

  142.   CreateObject("WScript.Shell").Run "cmd /c title " & WScript.ScriptName & _

  143.     " & cscript //nologo """ & WScript.ScriptFullName & """ & pause", 1, False

  144.   WScript.Quit(0)

  145. End Sub
复制代码
1

评分人数

『千江有水千江月』千江有水，月映千江；万里无云，万里青天。    http://yu2n.qiniudn.com/

TOP

xp3000

Rank: 5Rank: 5

帖子
441 
积分
618 
技术
37  
捐助
0  
注册时间
2013-4-25 
3楼
发表于 2015-6-24 17:06 | 只看该作者
辛苦了，好多代码，不过不知道为什么我这里没成功，ANSI和UTF-8和Unicode都试了，文件是UTF-8的

TOP

yu2n

Rank: 5Rank: 5

帖子
715 
积分
1298 
技术
151  
捐助
0  
注册时间
2012-11-1 
4楼
发表于 2015-6-24 17:19 | 只看该作者
回复 3# xp3000

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

不过注释这么多了，就是希望你自己也能改了。
『千江有水千江月』千江有水，月映千江；万里无云，万里青天。    http://yu2n.qiniudn.com/

TOP

xp3000

Rank: 5Rank: 5

帖子
441 
积分
618 
技术
37  
捐助
0  
注册时间
2013-4-25 
5楼
发表于 2015-6-25 06:41 | 只看该作者
谢谢，这个能用，麻烦下把HTML和HTM格式的支持也添加下吧

TOP

yu2n

Rank: 5Rank: 5

帖子
715 
积分
1298 
技术
151  
捐助
0  
注册时间
2012-11-1 
6楼
发表于 2015-6-25 08:01 | 只看该作者
回复 5# xp3000

修改第 10 行即可。


如 html 为：
  1.   Const sFileType = ".HTML"
复制代码
htm 为
  1.   Const sFileType = ".HTM"
复制代码
『千江有水千江月』千江有水，月映千江；万里无云，万里青天。    http://yu2n.qiniudn.com/

TOP

xp3000

Rank: 5Rank: 5

帖子
441 
积分
618 
技术
37  
捐助
0  
注册时间
2013-4-25 
7楼
发表于 2015-6-25 08:10 | 只看该作者
代码怎样同时支持三种格式？

TOP

yu2n

Rank: 5Rank: 5

帖子
715 
积分
1298 
技术
151  
捐助
0  
注册时间
2012-11-1 
8楼
发表于 2015-6-25 08:26 | 只看该作者
回复 7# xp3000

已更新。支持 .XHTML|.html|.htm ，更多的格式，自己添加。
『千江有水千江月』千江有水，月映千江；万里无云，万里青天。    http://yu2n.qiniudn.com/

TOP

xp3000

Rank: 5Rank: 5

帖子
441 
积分
618 
技术
37  
捐助
0  
注册时间
2013-4-25 
9楼
发表于 2015-6-25 08:44 | 只看该作者
谢谢很强大

TOP

返回列表