Тема: VBS: пакетное переименование HTML-файлов
С пылу с жару. ![]()
Скрипт для переименования HTML/HTM-файлов, также работает в пакетном режиме.
Новое имя файла задаётся на основе тега <title>.
На жутко загруженной машинке (Celeron 2,6Ghz, 1GB ram)
5372 файла обработал за ~1,5 минуты.
'************************************************************************
'* Name: Packet_HTML-renamer.vbs *
'* Language: VBScript *
'* commandline: Packet_HTML-renamer.vbs [file.htm|HTML-dir] *
'* Description: Скрипт предназначен для пакетного переименования *
'* HTM/HTML-файлов. Новое имя задаётся на основе *
'* TITLE-заголовка из содержимого файла. *
'* *
'* Author: Аскет *
'************************************************************************
On Error Resume Next
set FSO = CreateObject ("scripting.FileSystemObject")
'************** проверка аргументов ком. строки **************
if Wscript.Arguments.Length > 0 then
obj = wscript.Arguments.Item(0)
if FSO.FolderExists (obj) then parsefolder (obj)
if FSO.FileExists (obj) then parse (obj)
wsh.quit
end if
'************** Диалог выбора папки **************
set shellapp = CreateObject ("Shell.Application")
Set objFolder = shellapp.BrowseForFolder(0, "Папка с HTML",16, "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}")
if not FSO.FolderExists (objFolder.Self.Path) Then wsh.quit :else parsefolder (objFolder.Self.Path)
'************** Обработка папки **************
SUB parsefolder(folder)
set HTMLFolder = fso.GetFolder(folder)
old = Time()
For Each Fil In HTMLFolder.Files
if (LCase(FSO.GetExtensionName (Fil))="html") or (LCase(FSO.GetExtensionName (Fil))="htm") then
parse (Fil)
end if
Next
msgbox "Начало обработки: [" & old &"]"& vbcr & "Обработка папки закончена. [" & Time() & "]",,"Packet HTML renamer"
END SUB
'************** парсинг **************
SUB parse(fileName)
DIM titleflag: titleflag = false
UTF_charset = false
set file_ = fso.OpenTextFile (fileName)
Do While not (file_.AtEndOfLine) or (titleflag)
str = file_.ReadLine()
if (instr (str,"charset")>0) And (instr (str,"UTF-8")>0) then UTF_charset= true
if instr(LCase(str),LCase("<title>"))>0 then
titleflag = true
opentagindex = instr (LCase(str),"<title>")
closetagindex = instr (LCase(str),"</")
str = replace (str,LCase("</title>"),"")
str = replace (str,"/"," - ")
str = replace (str,"\"," - ")
STR = mid (str,opentagindex+7)
STR = Replace (STR,":"," ")
if (UTF_charset) then STR = UTF8toWin1251(STR)
file_.close()
RENAME FileName,STR
EXIT DO
end if
Loop
END SUB
'********* переименование файла **************
SUB RENAME(fileName,STR)
indexName=0
ParentFolder = FSO.GETPARENTFOLDERNAME(fileName) & "\"
oldName = FSO.GetBaseName (fileName)
fileext = "." & FSO.GetExtensionName (fileName)
NewName = ParentFolder & str
if fileName = (NewName & fileext) then exit sub
if fso.FileExists (NewName & fileext) then
while FSO.FileExists (NewName & "_(" & indexName & ")" & fileext)
indexName = indexName+1
wend
NewName = NewName & "_(" & indexName & ")"
end if
FSO.Movefile fileName, NewName & fileext
end sub
'********* UTF8 -> Win-1251 **************
Function UTF8toWin1251(sIn)
Set Recode = CreateObject("ADODB.Stream")
Recode.Open
Recode.CharSet = "windows-1251"
Recode.WriteText sIn
Recode.Position = 0
Recode.CharSet = "UTF-8"
UTF8toWin1251 = Recode.ReadText
Recode.Close
SET Recode = NOTHING
End Function
