Тема: VBScript/WSH: Конвертация flac в mp3
Написал скрипт конвертация flac в mp3. Описание в шапке.
'*********************************************************************************
'script : flac_v_mp3.vbs
'description : Recode flac to mp3
'usage : create a shortcut to this file in the "SendTo" folder or drag-drop folders on it or run with source path
'date : 01.10.2010
'version : 1.0
'req : flac.exe metaflac.exe http://flac.sourceforge.net/ lame.exe http://lame.sourceforge.net
'author : Ivan@Lapenkov.ru
' Описание
' У вас есть папка вида
' "I:\Звук\Классика\_Сборники\Великие композиторы"
' внутри которой папки и файлы, в том числе .flac :
' "I:\Звук\Классика\_Сборники\Великие композиторы\[01] Моцарт\01 - Маленькая ночная серенада соль мажор (KV 525) - Allegro.flac"
' Запускаете
' flac_v_mp3.vbs "I:\Звук\Классика\_Сборники\Великие композиторы"
' Создается папка
' "I:\Звук\Классика\_Сборники\Великие композиторы-mp3"
' внутри которой:
' "I:\Звук\Классика\_Сборники\Великие композиторы-mp3\[01] Моцарт\01 - Маленькая ночная серенада соль мажор (KV 525) - Allegro.mp3"
' или при запуске с настройкой RecodeRus=1 :
' "I:\Звук\Классика\_Сборники\Великие композиторы-mp3\[01] Mocart\01 - Malen'kaja nochnaja serenada sol' mazhor (KV 525) - Allegro.mp3"
' Переносятся теги, высокое качество, VBR, стерео. Все настройки кодирования можно изменить. На посторонние файлы внимания не обращает.
' Скрипт создает временный файл в %Temp%, из тегов удаляются символы "?*\/|<>:
' Скрипт можно запускать повторно, уже созданные файлы пропускаются.
'
' Скрипт требует следующие компоненты в своей папке:
' flac.exe metaflac.exe
' Версия 1.2.1
' http://flac.sourceforge.net
'
' lame.exe
' Версия 3.98.4
' http://lame.sourceforge.net
'
' Протестировано на WinXP Prof sp3 rus.
' Автор программы разрешает её свободное распространение и использование любых её фрагментов.
'*********************************************************************************
'***********************************
'Настройки
'***********************************
Option Explicit
' Настройки кодировщика LAME
Const LameKeys = "-V 0 --vbr-new -m s -q 2 --add-id3v2 --ignore-tag-errors --nohist --quiet"
' 1 - перекодировать имена файлов в транслит, 0 - нет. Удобно для устройств не поддерживающих кириллицу.
Const RecodeRus=0
' Пауза на сообщениях о некритических ошибках, секунды
Const PauseSize = 5
' 0 - окна кодировщиков скрыты, 1 - показываются
Const WindowState = 0
' Будет добавлено к имени исходной папки при создании выходной папки
Const sPostfixFolder = "-mp3"
' Расширения файлов
Const sExtToGet = "flac"
Const sExtToSet = "mp3"
' Название приложения
Const sAppName = "Конвертер FLAC в mp3"
' Таблицы конвертации символов
Const tr="а б в г д е ё ж з и й к л м н о п р с т у ф х ц ч ш щ ъ ы ь э ю я А Б В Г Д Е Ё Ж З И Й К Л М Н О П Р С Т У Ф Х Ц Ч Ш Щ Ъ Ы Ь Э Ю Я "
Const tl="аaбbвvгgдdеeёjoжzhзzиiйjjкkлlмmнnоoпpрrсsтtуuфfхkhцcчchшshщshhъ''ыyь'эehюjuяjaАAБBВVГGДDЕEЁJoЖZhЗZИIЙJjКKЛLМMНNОOПPРRСSТTУUФFХKhЦCЧChШShЩShhЪ''ЫYЬ'ЭEhЮJuЯJa"
'***********************************
'Начало основной программы
'***********************************
Dim fso, WshShell, Kav, cptTot, objArgs, arg, dicPath, TagKeys
Dim sSourceFolder, sSavePath, sTempFolder
Dim nTime
Set fso = CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("WScript.Shell")
Set dicPath = CreateObject("Scripting.Dictionary")
cptTot = 0
nTime = Timer
sTempFolder = WshShell.ExpandEnvironmentStrings("%Temp%")
If Not fso.FileExists("lame.exe") Then
WshShell.Popup "В папке со скриптом должен быть файл lame.exe", 0, sAppName, 48
WScript.Quit
End If
If Not fso.FileExists("flac.exe") Then
WshShell.Popup "В папке со скриптом должен быть файл flac.exe", 0, sAppName, 48
WScript.Quit
End If
If Not fso.FileExists("metaflac.exe") Then
WshShell.Popup "В папке со скриптом должен быть файл metaflac.exe", 0, sAppName, 48
WScript.Quit
End If
Set objArgs = WScript.Arguments
if (objArgs.Count = 0) then
WshShell.Popup "В командной строке должен быть путь к исходным файлам. Need source path in arguments.", 0, sAppName, 48
WScript.Quit
End If
'-- Работа
Call startScanning()
Call endPopup()
'-- Очистка
Set fso = nothing
Set WshShell = nothing
Set dicPath = nothing
'***********************************
'Конец основной программы
'***********************************
'***********************************
'Функции
'***********************************
Sub startScanning()
Dim arg, fold, sSourceFoldName
' перебирает пути из командой строки
For each arg in objArgs
If fso.FolderExists(arg) Then
Set sSourceFolder = fso.Getfolder(arg)
' Определимся с папкой для сохранения
sSourceFoldName = sSourceFolder.Path
sSavePath = sSourceFoldName & sPostfixFolder
dicPath.add sSavePath, sSavePath
' Создание папки для сохранения
If Not fso.FolderExists(sSavePath) Then
'WshShell.Popup "Создание папки " & sSavePath, PauseSize, sAppName, 64
fso.CreateFolder(sSavePath)
End If
'Обойдем папки, конвертируя
Call DoIt(sSourceFolder)
End If
Next
End Sub
'*********************************************************************************
Sub DoIt(fold)
' Рекурсия
Dim sfold, sfoo
Call ProceedFiles(fold) ' обработывает все файлы в текущей папке
Set sfold = fold.subfolders
for each sfoo in sfold ' работа с подпапками
Call DoIt(sfoo)
Next
End Sub
'*********************************************************************************
' Основная процедура обработки
Sub ProceedFiles(fold)
Dim RetCode, strExt, mpFiles, objFile, strName, strNameNew, foldPath, cpt, f, mp3filename, mp3filepath, tempfilename, flacfilename, RunFlacCommand, RunLameCommand
Dim temptagfile, temptagfilename, TagsText, TextLine
tempfilename = sTempFolder &"\"& FSO.GetTempName()
temptagfilename = sTempFolder &"\"& FSO.GetTempName()
If fso.FileExists(tempfilename) Then
fso.DeleteFile tempfilename, 1
End If
If fso.FileExists(temptagfilename) Then
fso.DeleteFile temptagfilename, 1
End If
cpt = 0
foldPath = fold.Path
mp3filepath = Replace(foldPath, sSourceFolder.Path, "")
If RecodeRus = 1 Then
mp3filepath=translit(mp3filepath)
End If
mp3filepath=sSavePath & mp3filepath
' ***** Создание конечной папки
If Not fso.FolderExists(mp3filepath) Then
fso.CreateFolder(mp3filepath)
End If
' ***** обработаем все файлы в папке
Set mpfiles = fold.Files
For each f in mpfiles
strName = f.Name
strExt = LCase(fso.GetExtensionName(strName)) ' Получим расширение
If strExt = sExtToGet Then
' ***** Подготовка имен файлов
flacfilename = foldPath &"\"& strName
strNameNew = Replace(strName, sExtToGet, sExtToSet)
If RecodeRus = 1 Then
strNameNew=translit(strNameNew)
End If
mp3filename = mp3filepath & "\" & strNameNew
' ***** Проверка нужности конвертации
If Not fso.FileExists(mp3filename) Then
' ***** Раскодирование во временный файл
RunFlacCommand = "flac -d -F -f """& flacfilename &""" -o """& tempfilename &""" "
RetCode = WshShell.Run(RunFlacCommand, WindowState , true)
If RetCode = 1 Then
WshShell.Popup " Ошибка в "& RunFlacCommand, PauseSize, sAppName, 48
End If
' если у файла назначения есть атрибут ReadOnly, снимаем его
If fso.FileExists(tempfilename) Then
Set objFile = FSO.GetFile(tempfilename)
If objFile.Attributes And 1 Then
objFile.Attributes = objFile.Attributes - 1
End If
set objFile = nothing
End If
' ***** теги
TagKeys="" ' главная переменная куда будут сохраняться ключи командной строки
RunFlacCommand = "metaflac.exe --export-tags-to="& temptagfilename &" """& flacfilename &""" "
RetCode = WshShell.Run(RunFlacCommand, WindowState , true)
If fso.FileExists(temptagfilename) Then
Set temptagfile = FSO.GetFile(temptagfilename)
Set TagsText = temptagfile.OpenAsTextStream(1,0)
Do While Not TagsText.AtEndOfStream
ParseTagToKeys(TagsText.ReadLine)
Loop
TagsText.Close
set temptagfile = nothing
fso.DeleteFile temptagfilename, 1
TagKeys = TagKeys &" --tv ""TENC=FLAC->LAME"""
End If
' ***** Кодирование в mp3
RunLameCommand = "lame "& LameKeys &" "& TagKeys &" """& tempfilename &""" """& mp3filename &""" "
RetCode = WshShell.Run(RunLameCommand, WindowState , true)
If not RetCode = 0 Then
WshShell.Popup " Ошибка в "& RunLameCommand, PauseSize, sAppName, 48
End If
' ***** Удаление временного файла
If fso.FileExists(tempfilename) Then
fso.DeleteFile tempfilename, 1
End If
cpt = cpt + 1
End If
End If
Next
cptTot = cptTot + cpt ' общий счетчик файлов
End Sub
'*********************************************************************************
Sub ParseTagToKeys(textline)
ParseTag textline,"TITLE", "--tt"
ParseTag textline,"YEAR","--ty"
ParseTag textline,"ARTIST","--ta"
ParseTag textline,"ALBUM","--tl"
ParseTag textline,"TRACKNUMBER","--tn"
ParseTag textline,"ENSEMBLE","--tv ""TCOM="
ParseTag textline,"ENSEMBLE","--tv ""TPE2="
ParseTag textline,"COMMENT","--tc"
'ParseTag textline,"GENRE","--tg" '"genre" нужно включать таблицу, но нет желания с ней возиться
'ParseTag textline,"ENCODER","" ' FLAC->LAME
End Sub
'*********************************************************************************
Sub ParseTag(textline,tag,cmdkey)
Dim TagText, Pos, TagKey
TagKey=""
tag=tag&"="
Pos=InStr(textline, tag)
If Not Pos=0 Then
TagText=Mid(textline, len(tag)+1)
TagText=StrConvert(TagText, "windows-1251", "cp866")
TagText = Replace(TagText, """", "'")
TagText = Replace(TagText, ":", " ")
TagText = Replace(TagText, "<", "'")
TagText = Replace(TagText, ">", "'")
TagText = Replace(TagText, "|", " ")
TagText = Replace(TagText, "?", " ")
TagText = Replace(TagText, "*", "+")
TagText = Replace(TagText, "/", " ")
TagText = Replace(TagText, "\", " ")
If RecodeRus = 1 Then
TagText=translit(TagText)
End If
If InStr(cmdkey, """")=0 Then ' часть cmdkey идёт с открытыми кавычками
TagKey=cmdkey & " """ & TagText & """"
Else
TagKey=cmdkey & TagText & """"
End If
TagKeys = TagKeys &" "& TagKey
End If
End Sub
'*********************************************************************************
'=============================================================================
' HKEY_CLASSES_ROOT\MIME\Database\Charset
' cp866, windows-1251, koi8-r, unicode, utf-8, _autodetect
'=============================================================================
Function StrConvert(ByVal strText, ByVal strSourceCharset, ByVal strDestCharset)
Const adTypeText = 2
Const adModeReadWrite = 3
With WScript.CreateObject("ADODB.Stream")
.Type = adTypeText
.Mode = adModeReadWrite
.Open
.Charset = strSourceCharset
.WriteText strText
.Position = 0
.Charset = strDestCharset
StrConvert = .ReadText
.Close
End With
End Function
Function showTime(nTime)
showTime = "Затрачено времени : " & Round((Timer - nTime),2) &" секунд"
End Function
'*********************************************************************************
' функция транслитерации строки по ГОСТ 7.79 2000
Function translit(ByVal sIncoming)
Dim pos, findpos, sSymbol
translit=""
For pos = 1 To len(sIncoming) Step 1
sSymbol=mid(sIncoming,pos,1)
findpos=InStr(1, tr, sSymbol)
If findpos=0 or sSymbol=" " Then
' ***** В транслитерации не нуждается
translit=translit+sSymbol
Else
' ***** Первый символ
translit=translit+mid(tl,findpos+1,1)
' ***** Второй символ
If mid(tr,findpos+2,1)=" " Then
translit=translit+mid(tl,findpos+2,1)
' ***** Третий символ
If mid(tr,findpos+3,1)=" " Then
translit=translit+mid(tl,findpos+3,1)
End If
End If
End If
Next
End Function
Sub endPopup()
WshShell.Popup "Завершено. " & chr(13) & chr(13) & cptTot & _
" файлов обработано в " & chr(13) & _
Join(dicPath.items, vbCrLf) & Chr(13) & Chr(13) & _
showTime(nTime), 0, sAppName, 64
End Sub
'*********************************************************************************
Если качество устраивает, то можете добавить в коллекцию.