'==================================================================== ' AJPapps - Make web name ' Линда Кайе 2009-2017. Посвящается Ариэль ' ' Этот скрипт я использую когда делаю обновления для сайта. Он ' переименовывает файлы так, чтобы они без проблем загружались на FTP ' сервера вроде FTP Народа. Иными словами, русские буквы заменяются ' транслитом, пробелы убираются, ну и так далее. Можно это делать ' ручками, а можно поручить этому скрипту. ' ' Окей. На самом деле это было программой, которую я писала на Visual ' Basic. Но потом я решила, что задача не слишком героическая, чтобы ' делать целый екзешник, поэтому я решила сделать скрипт. Правда, ' пришлось решить несколько проблем вроде определения, где мы вообще ' выполняемся, но в остальном всё было просто и весело ^^ Зато народ ' увидит мою маленькую велосипедную фабрику ^^ ' ' Оригинальная программа работала с 2008 года или около того ^^ ' ' • 24.09.2009 ' Первая версия ^^ ' ' • 7.08.2011 ' [+] В целях борьбы с narod2.ru, двойный точки заменяются ' на ".-.". ' ' • 14.12.2012 ' [+] Появились ключи /L и /U для изменения регистра ' результирующего файла. ' ' • 17.10.2014 ' [+] Борьба с Narod.ru подошла к концу. Теперь строгие правила ' замены (/S) и транслитерация кириллицы (/T) опциональны. ' [+] Появилась возможность вместо подчёркивания использовать ' тире. Используется ключ /H. ' ' • 3.03.2017 ' [+] Из имени файла убраны пробелы. ' [+] Поправлен вывод Usage. ' [-] Мелкие правки. ' '==================================================================== ' Маленький копирайт ' ' 1. Программа и исходный код распространяются бесплатно. ' 2. Вы имеете право распространять их на тех же условиях. ' 3. Вы не имеете права использовать имя автора после модификации ' исходного кода. ' 4. При этом желательно указывать ссылку на автора оригинальной ' версии исходного кода. ' 5. Вы не имеете права на платное распространение исходного кода, ' а также программных модулей, содержащих данный исходнй код. ' 6. Программа и исходный код распространяются как есть. Автор не ' несёт ответственности за любые трагедии или несчастные случаи, ' вызванные использованием программы и исходного кода. ' 7. Для любого пункта данного соглашения может быть сделано ' исключение с разрешения автора программы. ' 8. По любым вопросам, связанным с данной программой, обращайтесь ' по адресу lindaoneesama@gmail.com ' ' Загружено с http://purl.oclc.org/Linda_Kaioh/Homepage/ '==================================================================== Option Explicit Const AppTitle = "AJPapps - Make web name" Const AppCopyright = "Линда Кайе 2009-2017. Посвящается Ариэль" Dim FSO Dim Quet Dim ForceReplace Dim CopyOnly Dim LowerCase Dim UpperCase Dim StrictRules Dim TranslitRussian Dim UseHyphen Set FSO = CreateObject("Scripting.FileSystemObject") DetectArguments FinalEcho '==================================================================== Private Sub DetectArguments() Dim TMP Dim FileName If WScript.Arguments.Count = 0 Then ShowSplash ShowUsage Exit Sub End If ' Инициализируем переменые ^^' Quet = False ForceReplace = False CopyOnly = False LowerCase = False UpperCase = False StrictRules = False TranslitRussian = False UseHyphen = False For TMP = 0 To WScript.Arguments.Count - 1 Select Case UCase(WScript.Arguments(TMP)) Case "/?" ' Ладно, пусть будет... ShowSplash ShowUsage Exit Sub Case "/Q" Quet = True Case "/F" ForceReplace = True Case "/C" CopyOnly = True Case "/L" LowerCase = True Case "/U" UpperCase = True Case "/S" StrictRules = True Case "/T" TranslitRussian = True Case "/H" UseHyphen = True Case Else FileName = WScript.Arguments(TMP) End Select Next ShowSplash If FileName = "" Then ShowUsage Exit Sub End If RenameFile FileName End Sub '==================================================================== Private Sub ShowSplash() If Quet Then Exit Sub MyEcho AppTitle MyEcho AppCopyright MyEcho "" End Sub Private Sub ShowUsage() If Quet Then Exit Sub MyEcho "Использование:" MyEcho "" MyEcho " " & WScript.ScriptName & " [/F] [/Q] [/C] [/L] [/U] [/S] [/T] [/H] FileName" MyEcho "" MyEcho " FileName - имя переименовываемого файла." MyEcho " /F - форсировать замену файла, если он уже существует." MyEcho " /Q - не ныводить сообщений." MyEcho " /C - Только копировать. Оригинал не удаляется." MyEcho " /L - Перевести имя файла в нижний регистр." MyEcho " /U - Перевести имя файла в верхний регистр." MyEcho " /S - Строгие правила замены для сервиса narod.ru." MyEcho " /T - Транслитирировать кириллицу." MyEcho " /H - Использовать тире вместо подчёркивания." End Sub '==================================================================== Private Sub RenameFile(ByVal FileName) Dim NewName NewName = FSO.GetFileName(FileName) ' Пробелы в любом случае нужно заменить. If UseHyphen Then NewName = Replace(NewName, " ", "-") Else NewName = Replace(NewName, " ", "_") End If ' Строгие замены для закидонов Народа и Укоза. If StrictRules Then NewName = Replace(NewName, ",", "") NewName = Replace(NewName, "'", "") NewName = Replace(NewName, "(", "") NewName = Replace(NewName, ")", "") NewName = Replace(NewName, "[", "") NewName = Replace(NewName, "]", "") NewName = Replace(NewName, "+", "") NewName = Replace(NewName, "!", "I") NewName = Replace(NewName, "#", "_") NewName = Replace(NewName, "&", "_") NewName = Replace(NewName, "%", "_") End If ' Транслитирация для них же. If TranslitRussian Then NewName = TranslitName(NewName) ' Тоже финт ушами. narod2.ru не принимает несколько точек подряд =_= If StrictRules Then Do While InStr(NewName, "..") <> 0 NewName = Replace(NewName, "..", ".-.") Loop End If ' Регистр. Пусть верхний имеет приоритет! If LowerCase Then NewName = LCase(NewName) If UpperCase Then NewName = UCase(NewName) ' Финт ушами. Я могла бы использовать FSO.GetParentFolder(), но _ ' если имя файла указано так: \Byaka, то в итоге получится Byaka. _ ' Тоесть этот слэш просто будет срезан из пути, и путь станет _ ' пустой строкой. Не хочу такого, сделаю так. NewName = FSO.BuildPath(Left(FileName, Len(FileName) - Len(FSO.GetFileName(FileName))), NewName) ' О том, что это такое, читай ниже. If UCase(FileName) = UCase(NewName) Then MyEcho "Переименование файла не требуется." Exit Sub End If MyEcho "Исходный: " & FileName MyEcho "Новый: " & NewName MyEcho "" On Error Resume Next ' Тут логика такая. Так как MoveFile() не позволяет форсировать ' процесс, мы сначала копируем файл. А если не будет ошибок - ' удаляем исходный... ' Тут есть одна ловушка, если имя файла не изменилось, но я об ' этом позаботилась выше, сравнив новое и старое имена файлов. FSO.CopyFile FileName, NewName, ForceReplace If Err.Number = 0 Then ' Всё отлично, файл можно удалить. Если, конечно, не указан флаг. If CopyOnly Then MyEcho "Файл успешно скопирован." Else FSO.DeleteFile FileName MyEcho "Файл успешно переименован." End If Else MyEcho "Ошибка " & Err.Number MyEcho Err.Description End If End Sub '==================================================================== ' Транслитирация имени файла. Решила попробовать "японскую" ' стилистику. Тоесть Я заменяется не на A, не на JA, а на YA. ' Вроде даже читается лучше: Yama ^^ '==================================================================== Public Function TranslitName(ByVal Text) Dim TMP Dim RusChars Dim TransChars Dim Ch Dim Idx Dim Found ' Таблицы транслитирации. Ищем в первом массиве, берём замену из ' второго. Тупо и ясно ^^ RusChars = Array("а", "б", "в", "г", "д", "е", "ё", "ж", "з", _ "и", "й", "к", "л", "м", "н", "о", "п", "р", _ "с", "т", "у", "ф", "х", "ц", "ч", "ш", "щ", _ "ь", "ы", "ъ", "э", "ю", "я") TransChars = Array("a", "b", "v", "g", "d", "e", "yo", "j", "z", _ "i", "iy", "k", "l", "m", "n", "o", "p", "r", _ "s", "t", "u", "f", "h", "ts", "ch", "sh", _ "sh", "", "i", "", "e", "yu", "ya") For TMP = 1 To Len(Text) Ch = Mid(Text, TMP, 1) Idx = InArray(RusChars, LCase(Ch), Found) If Found Then If Ch = UCase(Ch) Then TranslitName = TranslitName & MyUCase(TransChars(Idx)) Else TranslitName = TranslitName & TransChars(Idx) End If Else TranslitName = TranslitName & Ch End If Next End Function '==================================================================== ' Эмуляция StrConv(..., vbProperCase) ' Делается с учётом того что у нас будут только одна или две буквы. '==================================================================== Private Function MyUCase(ByVal Text) If Len(Text) > 0 Then MyUCase = UCase(Left(Text, 1)) & Mid(Text, 2) End If End Function '==================================================================== ' Укороченная версия функции из CommonFunctions.DLL '==================================================================== Public Function InArray(ByRef ArrayX, _ ByVal FindWhat, _ ByRef IsFound) Dim TMP IsFound = False For TMP = LBound(ArrayX) To UBound(ArrayX) If ArrayX(TMP) = FindWhat Then IsFound = True InArray = TMP Exit Function End If Next End Function '==================================================================== ' Сия конструкция позволяет нам сказать, скрипт выполняется в консоли ' или нет. Результат кэшируется для скорости. Поскольку в VBScript ' нет ключевого слова Static, определим глобальную переменную прямо ' здесь. Это Variant, так что до кэширования она будет равна Empty. '==================================================================== Dim mInInCUI Private Function InInCUI() If IsEmpty(mInInCUI) Then ' Вычитаем из полного имени файла путь и обратный слэш. If UCase(Mid(WScript.FullName, Len(WScript.Path) + 2)) = "CSCRIPT.EXE" Then mInInCUI = True Else mInInCUI = False End If End If ' Возвращаем скэшированное значение... InInCUI = mInInCUI End Function '==================================================================== Dim mMessage Private Sub MyEcho(ByVal Text) If Quet Then Exit Sub If InInCUI() Then WScript.Echo Text Else mMessage = mMessage & Text & vbCrLf End If End Sub Private Sub FinalEcho() If Quet Then Exit Sub If Not InInCUI() Then MsgBox mMessage, vbInformation, AppTitle End Sub