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