1 Тема от 929151

  • 929151
  • Участник
  • Неактивен

Тема: VBS: Функция замены диакритических знаков схожими латинскими знаками

Нашёл функцию замены, но результат работы совсем не устраивает.


Option Explicit
Function EliminarAcentos(text)
    Dim i, s1, s2
    s1 = "ÁÀÉÈÍÏÓÒÚÜáàèéíïóòúüñçâ"
    s2 = "AAEEIIOOUUaaeeiioouunca"
    If Len(text) <> 0 Then
        For i = 1 To Len(s1)
            text = Replace(text, Mid(s1,i,1), Mid(s2,i,1))
        Next
    End If
    EliminarAcentos = text
End Function

WScript.Echo EliminarAcentos("Á")

В итоге на выходе получаю двойное "AA", а нужно одно А.

2 Ответ от Flasher

  • Flasher
  • Заблокирован
  • Неактивен

Re: VBS: Функция замены диакритических знаков схожими латинскими знаками

Сохранил код в UTF-16, запустил, на выходе только A. В коде проблем не вижу.

+ 929151

3 Ответ от 929151

  • 929151
  • Участник
  • Неактивен

Re: VBS: Функция замены диакритических знаков схожими латинскими знаками

Спасибо.

4 Ответ от omegastripes

  • omegastripes
  • Разработчик
  • Неактивен

Re: VBS: Функция замены диакритических знаков схожими латинскими знаками

Всего таких знаков 221 среди основных в диапазоне кодов 192..609:

À Á Â Ã Ä Å Æ Ç È É Ê Ë Ì Í Î Ï Ð Ñ Ò Ó Ô Õ Ö Ø Ù Ú Û Ü Ý à á â ã ä å æ ç è é ê ë ì í î ï ñ ò ó ô õ ö ø ù ú û ü ý ÿ Ā ā Ă ă Ą ą Ć ć Ĉ ĉ Ċ ċ Č č Ď ď Đ đ Ē ē Ĕ ĕ Ė ė Ę ę Ě ě Ĝ ĝ Ğ ğ Ġ ġ Ģ ģ Ĥ ĥ Ħ ħ Ĩ ĩ Ī ī Ĭ ĭ Į į İ ı Ĵ ĵ Ķ ķ Ĺ ĺ Ļ ļ Ľ ľ Ł ł Ń ń Ņ ņ Ň ň Ō ō Ŏ ŏ Ő ő Œ œ Ŕ ŕ Ŗ ŗ Ř ř Ś ś Ŝ ŝ Ş ş Š š Ţ ţ Ť ť Ŧ ŧ Ũ ũ Ū ū Ŭ ŭ Ů ů Ű ű Ų ų Ŵ ŵ Ŷ ŷ Ÿ Ź ź Ż ż Ž ž ƀ Ɖ Ƒ ƒ Ɨ ƚ Ɵ Ơ ơ ƫ Ʈ Ư ư ƶ Ǎ ǎ Ǐ ǐ Ǒ ǒ Ǔ ǔ Ǖ ǖ Ǘ ǘ Ǚ ǚ Ǜ ǜ Ǟ ǟ Ǥ ǥ Ǧ ǧ Ǩ ǩ Ǫ ǫ Ǭ ǭ ǰ ɡ

Можно расширить строки s1 и s2 в представленной выше функции, а я в свое время использовал следующий код:


Option Explicit

Dim oDiaDict

' Инициализация словаря единократно при запуске
Set oDiaDict = GetDiaDict()

' Проверка
MsgBox Replace_Diacritics("ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝàáâãäåæçèéêëìíîïñòóôõöøùúûüýÿĀāĂ㥹ĆćĈĉĊċČčĎďĐđĒēĔĕĖėĘęĚěĜĝĞğĠġĢģĤĥĦħĨĩĪīĬĭĮįİıĴĵĶķĹĺĻļĽľŁłŃńŅņŇňŌōŎŏŐőŒœŔŕŖŗŘřŚśŜŝŞşŠšŢţŤťŦŧŨũŪūŬŭŮůŰűŲųŴŵŶŷŸŹźŻżŽžƀƉƑƒƗƚƟƠơƫƮƯưƶǍǎǏǐǑǒǓǔǕǖǗǘǙǚǛǜǞǟǤǥǦǧǨǩǪǫǬǭǰɡ", oDiaDict)

Function Replace_Diacritics(sText, oDict)
	
	Dim i, sChar, aRes
	
	aRes = Array()
	ReDim aRes(Len(sText))
	For i = 1 To Len(sText)
		sChar = Mid(sText, i, 1)
		If oDict.Exists(sChar) Then
			aRes(i) = oDict(sChar)
		Else
			aRes(i) = sChar
		End If
	Next
	Replace_Diacritics = Join(aRes, "")
	
End Function
	
Function GetDiaDict()
	
	Dim oDict, i, sRange, sCured, sChar
	
	Set oDict = CreateObject("Scripting.Dictionary")
	sRange = ""
	For i = 192 To 609
		sRange = sRange & ChrW(i)
	Next
	With CreateObject("ADODB.Stream")
		.Type = 2
		.Mode = 3
		.Open
		.Charset = "ascii"
		.WriteText sRange
		.Position = 0
		sCured = .ReadText
		.Close
	End With
	For i = 192 To 609
		sChar = Mid(sCured, i - 191, 1)
		If sChar <> "?" Then oDict(ChrW(i)) = sChar
	Next
	Set GetDiaDict = oDict
	
End Function
Щт Уккщк Куыгьу Туче
’ҐЄгй п Є®¤®ў п бва Ёж : 1251