ранслитерация строки для использования в URL

Функция транслитерации текстовой строки для использования в URL с зачисткой от запрещённых символов и переводом в нижний регистр

Function TranslitForURL(val As Variant, Optional sZamena As String = "_") As String

' es - 13.12.2015

' VBA функция транслитерации текстовой строки для использования в URL

' с зачисткой от запрещённых символов и переводом в нижний регистр

'--------------------------------------------------------------------

' Возвращает модифицированную строку

' Аргументы:

' val = входящая строка (значение поля)

' sZamena = Символ замены для пробелов и проч. (по умолчанию = "_")

'--------------------------------------------------------------------

' Считается, что в URL адресе, допустимы_только латинские буквы, арабские цифры _

' и ограниченный набор знаков (-_.), а прочие знаки (!@#$&~%*()[]{}'\:;><`,)- недопустимы.

' Коды символов можно найти например тут:

' http://autoit-script.ru/autoit3_docs/appendix/ascii.htm

'--------------------------------------------------------------------

Dim strRussian As String

Dim arrTranslit As Variant

Dim iPos As Integer

Dim sTemp As String

Dim sResult As String

Dim str As String

'--------------------------------------------------------------------

On Error GoTo TranslitForURL_Err

str = CStr(val)

' Очистка строки - оставляем только приемлемые символы и переводим в нижний регистр

For iPos = 1 To Len(str)

sTemp = LCase(Mid(str, iPos, 1))

Select Case Asc(sTemp)

Case 32 'Пробел

sResult = sResult & sTemp

Case 45 'Дефис, минус (по желанию)

If sZamena = "-" Then

sResult = sResult & sTemp

Else ' Тут меняем на пробел

sResult = sResult & " "

End If

Case 48 To 57 'цыфири

sResult = sResult & sTemp

Case 65 To 90, 97 To 122, 192 To 255 'Буквы англ + рус

sResult = sResult & sTemp

Case 95 'Нижнее подчёркивание

sResult = sResult & " "

'Дальше по желанию

End Select

Next

str = Trim(sResult)

'Debug.Print str

Do While InStr(1, str, Space(2), 1) <> 0 'Убираем (возможные) лишние пробелы

str = Replace(str, Space(2), Space(1), vbTextCompare)

Loop

'Собственно транлитирование -

strRussian = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя "

'Произвольный массив для замены - И никаких апострофов!!!

'arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "jo", "zh", "z", "i", "y", "k", _

"l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "h", "c", "ch", _

"sh", "zch", "", "i", "", "eh", "ju", "ja", sZamena)

'Международный стандарт Doc 9303, рекомендованный ИКАО:

arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "i", "k", _

"l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "tc", "ch", _

"sh", "shch", "ie", "y", "", "e", "iu", "ia", sZamena)

For iPos = 1 To 34

str = Replace(str, Mid(strRussian, iPos, 1), arrTranslit(iPos), , , vbTextCompare) '

Next

TranslitForURL = str

TranslitForURL_Bye:

Exit Function

TranslitForURL_Err:

TranslitForURL = "! Err in string: " & str

' MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & _

"в процедуре: TranslitForURL", vbCritical, "Error!"

Resume TranslitForURL_Bye

End Function

Пример использования функции TranslitForURL:

Private Sub test_TranslitForURL()

'Пример эксплуотации функции TranslitForURL

'--------------------------------------------------------------------

Dim s1 As String

Dim s2 As String

Dim s3 As String

'Проверять функцию транслитирования лучше на длинной и сложной строке:

s1 = "Считается, что в URL адресе, допустимы только "

s2 = "латинские буквы, арабские цифры и ограниченный набор знаков (-_.), "

s3 = "а прочие знаки (!@#$&~%*()[]{}'\;><`:,)- недопустимы."

s1 = TranslitForURL(s1, "-") 'Вариаант с заменой "грязи" на "-" (дефис)

s2 = TranslitForURL(s2, "-")

s3 = TranslitForURL(s3, "_") 'Вариаант с заменой на ""_"" (нижнее подчёркивание):"

Debug.Print s1

Debug.Print s2

Debug.Print s3

End Sub

Пример эксплуотации в Immediate Window (Ctrl+G) напишет:

schitaetsia-chto-v-url-adrese-dopustimy-tolko

latinskie-bukvy-arabskie-tcifry-i-ogranichennyi-nabor-znakov--

a_prochie_znaki_nedopustimy