批处理之家 - Powered by Discuz! Board

' VBS 批量修改XHTML文件名为title值 By Yu2n.vbs
Option Explicit
'指定文件类型、文件编码
Const sFileType = ".XHTML|.html|.htm"
Const sCharset = "utf-8"
Call CommandMode()
Main
Sub Main()
'选择文件夹
Dim strFolder, arrPath, strPath, nCount, i
strFolder = BrowseForFolder("请选择要重命名的 " & sFileType & " 文件所在目录：")
If strFolder = "" Then
WScript.Echo vbCrLf & " --- 错误：没有选择文件夹。程序即将退出 ..." & vbCrLf
Exit Sub
End If
'扫描文件夹
arrPath = ScanFolder(strFolder)
'统计个数，用于显示进度
For Each strPath In arrPath
If InStr(1,"|"&sFileType&"|","|."&GetExtensionName(strPath)&"|",vbTextCompare)>0 Then
nCount=nCount+1
End If
Next
'执行批量处理
Dim dtStart, objWord : dtStart=Now() '计时
For Each strPath In arrPath
If InStr(1,"|"&sFileType&"|","|."&GetExtensionName(strPath)&"|",vbTextCompare)>0 Then
i=i+1 '计数
WScript.Echo "[" & i & "/" & nCount & "]" & strPath ' 显示进度
Call ReNameByTitle(strPath) ' 执行替换
End If
Next
'显示结果
WScript.Echo vbCrLf & " --- 完成。总计 " & nCount & " 个文档完成操作，耗时 " _
& DateDiff("s",dtStart,Now()) & " 秒。" & vbCrLf
End Sub
'重命名xml文件（依据title值）
Function ReNameByTitle(ByVal sFile)
ReNameByTitle = False
Dim fso, sFp, sFx, sFn, sFf
Set fso = CreateObject("Scripting.FileSystemObject")
sFp = fso.GetFile(sFile).ParentFolder
sFx = fso.GetExtensionName(sFile)
sFn = GetHtmlTitle(sFile)
sFf = sFp & "\" & sFn & "." & sFx
If sFn = "" Then Exit Function
fso.GetFile(sFile).Move sFf
ReNameByTitle = fso.FileExists(sFf)
End Function
'获取xml文件title值
Function GetHtmlTitle(ByVal sFile)
Dim oHtml, sHtml, oTitle
Set oHtml = CreateObject("htmlfile")
oHtml.DesignMode = "on" ' 开启编辑模式
sHtml = Pfile(sFile, sCharset, "") 'sHtml = Pfile(sFile, "utf-8", "")
oHtml.Write sHtml ' 写入数据
Set oTitle = oHtml.getElementsByTagName("title")
If Not oTitle Is Nothing Then GetHtmlTitle=oTitle(0).innerHTML
End Function
'获取文件拓展名
Function GetExtensionName(ByVal sPath)
Dim sFf, sFnx, sFx
sFf = Trim(sPath)
If sFf <> "" Then sFnx = Split(sFf, "\")(UBound(Split(sFf, "\")))
If sFnx <> "" Then sFx = Split(sFnx, ".")(UBound(Split(sFnx, ".")))
GetExtensionName = sFx
End Function
' 浏览文件夹
Function BrowseForFolder(ByVal strTips)
Dim objFolder
Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)
If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path 'objFolder.Items().Item().Path
End Function
' 获取文件夹所有文件夹、文件列表(数组)
Function ScanFolder(ByVal strFolder)
If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
Dim arrList() : ReDim Preserve arrList(0) : arrList(0) = strFolder
Call DO_SCAN_FOLDER(arrList, strFolder) : ScanFolder = ArraySort(arrList)
End Function
Function DO_SCAN_FOLDER(ByRef arrList, ByVal strFolder)
On Error Resume Next
Dim fso, objItems, objFile, objFolder
Set fso = CreateObject("Scripting.FileSystemObject")
Set objItems = fso.GetFolder(strFolder)
If (Not fso.FolderExists(strFolder)) Then Exit Function
For Each objFile In objItems.Files
ReDim Preserve arrList(UBound(arrList) + 1)
arrList(UBound(arrList)) = objFile.Path
Next
For Each objFolder In objItems.subfolders
ReDim Preserve arrList(UBound(arrList) + 1)
arrList(UBound(arrList)) = objFolder.Path & "\"
Call DO_SCAN_FOLDER(arrList, objFolder.Path & "\")
Next
End Function
Function ArraySort(ByVal arr)
Dim i, j, tmp
For i=1 To UBound(arr)
For j=i To 1 Step -1
If CStr(arr(j))<CStr(arr(j-1)) Then
tmp=arr(j) : arr(j)=arr(j-1) : arr(j-1)=tmp
End If
Next
Next
ArraySort = arr
End Function
'Pfile()
'对文本指定编码进行读写操作
'指定编码写入 Call Pfile("C:\1.txt", "utf-8", strText)
'指定编码读取 strText = "" : Call Pfile("C:\1.txt", "utf-8", strText)
'FileCode: ANSI/UTF-8/Unicode/ULE/UBE/GB2312/GBK/Big5/日文EUC-JP/韩文EUC-KR
Function Pfile(ByVal sFile, ByVal FileCode, ByRef sText)
With CreateObject("ADODB.Stream")
.Type=2 : .Mode=3 : .Charset=FileCode : .Open
If sText="" Then
.LoadFromFile sFile : sText=.ReadText : Pfile=sText
Else
.WriteText sText : .SaveToFile sFile, 2
End If
.Close
End With
End Function
'Command Mode
Sub CommandMode()
If InStr(1, WScript.FullName, "\cscript.exe", vbTextCompare) > 0 Then Exit Sub
CreateObject("WScript.Shell").Run "cmd /c title " & WScript.ScriptName & _
" & cscript //nologo """ & WScript.ScriptFullName & """ & pause", 1, False
WScript.Quit(0)
End Sub