Microsoft Excel

Herbers Excel/VBA-Archiv

Punycode > Unicode


Betrifft: Punycode > Unicode
von: Bernd G.
Geschrieben am: 20.12.2010 10:07:29

Hallo liebe Excelisten,
ich habe eine Liste mit Domainnamen in Punycode.
Hat jemand eine Idee, wie ich das in "normale" Zeichen umsetzen kann.
Habe im I-Net nichts gefunden.

Wobei mir der Begriff Punicode neu ist, aber in Wikipedia wird's erklärt.

Ich bräuchte einen VBA-Code, der mir z.B. aus "xn--schn-abc" "schön.de" macht.
Hat jemand eine Idee?

Viele Grüße
Bernd G.

  

Betrifft: AW: Punycode > Unicode
von: Tino
Geschrieben am: 20.12.2010 10:37:57

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


  

Betrifft: AW: Punycode > Unicode
von: Bernd G.
Geschrieben am: 20.12.2010 11:41:37

suuper genial ich bin begeistert

Wie findet man so was???

Gruß
Bernd G.


  

Betrifft: AW: Punycode > Unicode
von: Reinhard
Geschrieben am: 20.12.2010 12:14:15

Hallo Bernd,

suche im Internet nach

+vb +punycode = der 1te Treffer

+vba +punycode = der 5te Treffer

Gruß
Reinhard


  

Betrifft: AW: Punycode > Unicode
von: Reinhard
Geschrieben am: 20.12.2010 10:54:28

Hallo Bernd,

wenn man bei http://www.activevb.de bei "Suchen" "Punycode eingibt hat meinen Treffer, eine VB.zip zum Runterladen.

Beim zip-Link steht:
Diese Modul exportiert die Funktion EncodeHost(), mit der man Domainnamen nach Punycode 
(Codierung für die "Umlaut-Domains") konvertieren kann. Update (22.03.2004): Das Modul 
exportiert nun auch die Funktion DecodeHost(), mit der sich Hostnamen von Punycode nach Unicode  _

zurückverwandeln lassen. Zudem wurde das Modul in ein kleines Beispielprojekt gepackt.
Von Achim Neubauer, 3528 Bytes zuletzt aktualisiert am 22.03.04 um 18.54 Uhr
Nachfolgend ist der Code daraus.

Tja nun, ist halt für VB geschrieben....

Gruß
Reinhard




'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



  

Betrifft: AW: Punycode > Unicode
von: Reinhard
Geschrieben am: 20.12.2010 11:07:05

Hallo Bernd,

in Excel 2000 getestet, füge noch diese Codes dazu und starte "Testen".

Sub Testen()
  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)
  Static Zei As Long
   Zei = Zei + 1
  Const Delimiter As String = " -> "
  Cells(Zei, 1) = Hostname & Delimiter & EncodeHost(Hostname) & Delimiter & DecodeHost( _
EncodeHost(Hostname))
  'Debug.Print Hostname & Delimiter & EncodeHost(Hostname) & Delimiter & DecodeHost(EncodeHost( _
Hostname))
End Sub
Gruß
Reinhard


  

Betrifft: AW: Punycode > Unicode
von: Bernd G.
Geschrieben am: 20.12.2010 11:56:51

Hallo Reinhard,
auch Dir noch einmal vielen Dank.

Das hat mir echt weitergeholfen

Gruß
Bernd


  

Betrifft: AW: Punycode > Unicode
von: Reinhard
Geschrieben am: 21.12.2010 21:57:07

Hallo Bernd oder andere die es wissen,

wozu brauchst das?

Vor vilen Jahren las ich mal daß demnächst auch in Internetadressen auch Sonderzeichen zugelassen sind,
also Buchstaben mit waagrechtenm Doppelpunkt darüber, oder Akcent tegu (nicht auf die Schreibweise achten *gg*) in Frankreich.

Bin da nicht aktuell, klappt das schon?

Und, wenn ja, beruht das auf Punycode?

Und was will bernd damit? Baust du/er dir/sich einen eigenen Browser? *rätsel*

Danke ^ Gruß
Reinhard


  

Betrifft: AW: Punycode > Unicode
von: Bernd G.
Geschrieben am: 22.12.2010 07:20:11

Hallo Reinhard,
nein viel schlichter. Ich habe eine Liste mit Domains, die beantragt wurden bzw. werden sollen und die mir im Punycode geliefert werden. Dabei kommt es vor, dass die Benutzer Umlaute verwenden und das soll
umgewandelt werden, damit ich einen schnelleren Überblick habe, wie die Domain denn nun heissen soll bzw heißt.

Gruß
Bernd


  

Betrifft: Danke für die Info Gruß o.w.T.
von: Reinhard
Geschrieben am: 22.12.2010 11:02:21