Преобразование URL национального домена в punycode

Sub ПримерИспользования_ConvertURLtoPunycode()
    Dim host$, newURL$
 
    ' исходная ссылка
    host$ = "http://государство.президент.рф/советы"
 
    ' результат преобразования: "http://xn--80aebe3cdmfdkg.xn--d1abbgf6aiiy.xn--p1ai/%D1%81%D0%BE%D0%B2%D0%B5%D1%82%D1%8B"
    newURL$ = ConvertURLtoPunycode(host$)
    MsgBox newURL$
End Sub

'****************************************
'* Converts Domainnames from Unicode to Punycode and vice versa             *
'* Programmed: Achim Neubauer           Last Change: 22.03.2004 18:39       *
'****************************************
' source: http: //www.herber.de/forum/archiv/1192to1196/1192164_Punycode_Unicode.html
' Edited 25.01.2015 by ExcelVBA.ru    http: //excelvba.ru/code/punycode

Option Explicit
 
'Punycode constants
Private Const BASE As Long = 36, TMIN As Long = 1, TMAX As Long = 26, SKEW As Long = 38, DAMP As Long = 700
Private Const INITIAL_BIAS As Long = 72, INITIAL_N As Long = 128
'********************************************************************************

Function ConvertURLtoPunycode(ByVal URL$) As String
    ' преобразует URL национальных доменов в Punycode
    ' например, ссылка http: //государство.президент.рф/советы
    ' преобразуется в http: //xn--80aebe3cdmfdkg.xn--d1abbgf6aiiy.xn--p1ai/%D1%81%D0%BE%D0%B2%D0%B5%D1%82%D1%8B
    ' если ссылка ведет на обычный (международный домен), приеобразование не выполняется
    ' дополнительно выполняется преобразование ссылки в URLencode

    On Error Resume Next
    Dim arr, host$, i&, l$, t$, txt$
    arr = Split(URL$, "/")
    arr(2) = EncodeHost(arr(2))        ' Punycode
    txt$ = Join(arr, "/")
 
    For i = 1 To Len(txt)
        l = Mid(txt, i, 1)
        Select Case AscW(l)
            Case Is > 256
                t = "%" & Hex(AscW(l) \ 64 + 192) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
            Case 32: t = "+"
            Case Else: t = l
        End Select
        ConvertURLtoPunycode = ConvertURLtoPunycode & t
    Next
End Function

Public Function EncodeHost(ByVal Name As String) As String
    If Len(Name) = 0 Then Exit Function
    Dim arrLevels() As String, t As Long
 
    arrLevels = Split(Name, ".")
    For t = 0 To UBound(arrLevels)
        arrLevels(t) = Replace(arrLevels(t), "?", "ss")
        arrLevels(t) = Encode(arrLevels(t))
    Next t
    EncodeHost = Join(arrLevels, ".")
End Function
 
Public Function DecodeHost(Name As String) As String
    If Len(Name) = 0 Then Exit Function
    Dim arrLevels() As String, t As Long
    arrLevels = Split(Name, ".")
    For t = 0 To UBound(arrLevels)
        If Left$(LCase$(arrLevels(t)), 4) = "xn--" Then
            arrLevels(t) = Decode(Mid$(arrLevels(t), 5))
        End If
    Next t
    DecodeHost = Join(arrLevels, ".")
End Function
'********************************************************************************

Private Function Encode(text As String) As String
    On Error GoTo Ende
    Dim n&, delta&, bias&, b&, output$, l&, c$, h&, q&, m&, k&, t&
    bias = INITIAL_BIAS: n = INITIAL_N
    For l = 1 To Len(text)
        c = Mid$(text, l, 1)
        If IsBasic(c, INITIAL_N) Then output = output & c: b = b + 1
    Next l
    If Len(output) < Len(text) Then
        If Len(output) > 0 Then output = output & "-"
        output = "xn--" & output
    End If
 
    h = b
    While h < Len(text)
        m = GetMinCodePoint(n, text)
        delta = delta + UInt(m - n) * (h + 1)
        n = m
        For l = 1 To Len(text)
            c = Mid$(text, l, 1)
            If IsBasic(c, n) Then
                delta = delta + 1
            ElseIf UInt(AscW(c)) = n Then
                q = delta
                For k = BASE To &H7FFFFFFF Step BASE
                    If k <= bias + TMIN Then
                        t = TMIN
                    ElseIf k >= bias + TMAX Then
                        t = TMAX
                    Else
                        t = k - bias
                    End If
                    If q < t Then Exit For
                    output = output & Chr(Digit2Codepoint(t + ((q - t) Mod (BASE - t))))
                    Let q = (q - t) \ (BASE - t)
                Next k
                output = output & Chr(Digit2Codepoint(q))
                bias = Adapt(delta, h + 1, (h = b))
                delta = 0: h = h + 1
            End If
        Next l
        delta = delta + 1: n = n + 1
    Wend
 
Ende:
    Encode = output
End Function
 
Private Function Decode(text As String) As String
    On Error GoTo Ende
    Dim n&, i&, bias&, output$, l&, pos&, c$, oldi&, w&, k&, digit As Byte, t&
    n = INITIAL_N: bias = INITIAL_BIAS
    pos = InStrRev(text, "-")
    If pos > 0 Then
        For l = 1 To pos - 1
            c = Mid$(text, l, 1)
            If IsBasic(c, INITIAL_N) Then output = output & c Else Exit Function
        Next l
    End If
 
    pos = pos + 1
    Do While (pos <= Len(text))
        oldi = i: w = 1
        For k = BASE To &H7FFFFFFF Step BASE
            If pos > Len(text) Then Exit For        'out of code points
            c = Mid$(text, pos, 1)
            pos = pos + 1
            digit = Codepoint2Digit(Asc(c))
            If digit = 255 Then Exit Function        'bad code point
            i = i + digit * w
            If k <= bias Then
                t = TMIN
            ElseIf k >= bias + TMAX Then
                t = TMAX
            Else
                t = k - bias
            End If
            If digit < t Then Exit For
            w = w * (BASE - t)
        Next k
        bias = Adapt(i - oldi, Len(output) + 1, (oldi = 0))
        n = n + i \ (Len(output) + 1)
        i = i Mod (Len(output) + 1)
        If IsBasic(ChrW(n), INITIAL_N) Then Exit Function        'shouldn't be a basic code point
        output = Left$(output, i) & ChrW(n) & Mid$(output, i + 1)
        i = i + 1
    Loop
Ende:
    Decode = output
End Function

Private Function GetMinCodePoint(ByVal n As Long, ByVal data As String) As Long
    Dim t&, a&, result&
    result = &H7FFFFFFF
    For t = 1 To Len(data)
        a = UInt(AscW(Mid$(data, t, 1)))
        If (a >= n) And (a < result) Then result = a
    Next t
    GetMinCodePoint = result
End Function
 
Private Function IsBasic(c As String, ByVal n As Long) As Boolean
    IsBasic = (UInt(AscW(c)) < n)
End Function
 
Private Function Adapt(ByVal delta As Long, ByVal numpoints As Long, ByVal firsttime As Boolean) As Long
    Dim k As Long
    If (firsttime) Then delta = delta \ DAMP Else delta = delta \ 2
    delta = delta + (delta \ numpoints)
    k = 0
    While (delta > ((BASE - TMIN) * TMAX) \ 2)
        delta = delta \ (BASE - TMIN)
        k = k + BASE
    Wend
    Adapt = k + (((BASE - TMIN + 1) * delta) \ (delta + SKEW))
End Function
 
Private Function Digit2Codepoint(ByVal d As Long) As Long
    If (d < 26) Then
        Digit2Codepoint = d + &H61        'a'
    ElseIf (d < 36) Then
        Digit2Codepoint = d - 26 + &H30        '0'
    Else
        Debug.Print "Error in Function Digit2Codepoint"
    End If
End Function
 
Private Function Codepoint2Digit(ByVal c As Long) As Long
    If (c - &H30 < 10) Then        '0'
        Codepoint2Digit = 26 + c - &H30        '0'
    ElseIf (c - &H41 < 26) Then        'a'
        Codepoint2Digit = c - &H41        'a'
    ElseIf (c - &H61 < 26) Then        'A'
        Codepoint2Digit = c - &H61        'A'
    Else
        Codepoint2Digit = 255
        Debug.Print "Error in Function Codepoint2Digit"
    End If
End Function
 
Private Function UInt(i As Integer) As Long
    If i < 0 Then UInt = 2 ^ 16 + i Else UInt = i
End Function