AW: Punycode > Unicode
20.12.2010 10:37:57
Tino
Hallo,
dies habe ich bei http://www.activevb.de
gefunden, vielleicht kannst Du damit was anfangen.
Leider habe ich nur das Projekt gefunden, daher stelle ich einfach den Code mal hier rein.
'Dieser Source stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.
'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source !
'****************************************
'* modPunycode.bas *
'* Converts Domainnames from Unicode to *
'* Punycode and vice versa *
'* Programmed: Achim Neubauer *
'* Last Change: 22.03.2004 18:39 *
'* Version: 1.0.1 *
'****************************************
'For more Information about Punycode, see the RFC 3492 at http://www.rfc-editor.org
Option Explicit
'Punycode constants
Private Const BASE As Long = 36
Private Const TMIN As Long = 1
Private Const TMAX As Long = 26
Private Const SKEW As Long = 38
Private Const DAMP As Long = 700
Private Const INITIAL_BIAS As Long = 72
Private Const INITIAL_N As Long = 128
Private Const Delimiter As String = "-"
'********************************************************************************
Public Function EncodeHost(Name As String) As String
If Len(Name) = 0 Then Exit Function
Dim arrLevels() As String
Dim 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
Dim 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 As Long: n = INITIAL_N
Dim delta As Long
Dim bias As Long: bias = INITIAL_BIAS
Dim b As Long
Dim output As String
Dim l As Long
Dim c As String
For l = 1 To Len(text)
c = Mid$(text, l, 1)
If IsBasic(c, INITIAL_N) Then
output = output & c
b = b + 1
End If
Next l
If Len(output) < Len(text) Then
If Len(output) > 0 Then
output = output & Delimiter
End If
output = "xn--" & output
End If
Dim h As Long
Dim q As Long
Dim m As Long
Dim k As Long
Dim t As Long
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 As Long: n = INITIAL_N
Dim i As Long
Dim bias As Long: bias = INITIAL_BIAS
Dim output As String
Dim l As Long
Dim pos As Long
Dim c As String
pos = InStrRev(text, Delimiter)
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 'non-basic code point before last delimiter
End If
Next l
End If
pos = pos + 1
Dim oldi As Long
Dim w As Long
Dim k As Long
Dim digit As Byte
Dim t As Long
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 As Long
Dim a As Long
Dim result As Long
result = &H7FFFFFFF
For t = 1 To Len(data)
a = UInt(AscW(Mid$(data, t, 1)))
If (a >= n) And (a < result) Then
result = a
End If
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 "Digit außerhalb des gültigen Bereichs."
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 "Codepoint außerhalb des gültigen Bereichs."
End If
End Function
Private Function UInt(i As Integer) As Long
If i < 0 Then
UInt = 2 ^ 16 + i
Else
UInt = i
End If
End Function
Private Sub Form_Load()
TestHostname "www.schüler.de"
TestHostname "www.colinschüter.de"
TestHostname "www.müller.de"
TestHostname "www.ündernätiönäle-dömäin.de"
End Sub
Private Sub TestHostname(Hostname As String)
Const Delimiter As String = " -> "
Debug.Print Hostname & Delimiter & EncodeHost(Hostname) & Delimiter & DecodeHost(EncodeHost(Hostname))
End Sub
Gruß Tino