Alex_Piggy
Advanced Member | Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
Код:
Set objArgs = WScript.Arguments
MsgBox translit(objArgs(I))
'=============================================================================
' функция транслитерации строки по ГОСТ 7.79 2000
Function translit(ByVal sIncoming)
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 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 |
|
