Wie kann ich eine Zeichenfolge in Excel VBA per URL codieren?

76

Gibt es eine integrierte Möglichkeit, eine Zeichenfolge in Excel VBA per URL zu codieren, oder muss ich diese Funktionalität manuell ausführen?

excel vba url encoding urlencode Matthew Murdoch
quelle

Antworten:

89

Nein, nichts eingebaut ( bis Excel 2013 - siehe diese Antwort ).

URLEncode()Diese Antwort enthält drei Versionen von .

  • Eine Funktion mit UTF-8-Unterstützung. Sie sollten wahrscheinlich diese (oder die alternative Implementierung von Tom) verwenden, um die Kompatibilität mit modernen Anforderungen zu gewährleisten.
  • Zu Referenz- und Bildungszwecken zwei Funktionen ohne UTF-8-Unterstützung:
    • eine, die auf einer Website eines Drittanbieters gefunden wurde und so wie sie ist enthalten ist. (Dies war die erste Version der Antwort)
    • eine optimierte Version davon, geschrieben von mir

Eine Variante, die die UTF-8-Codierung unterstützt und auf der basiert ADODB.Stream(Verweis auf eine aktuelle Version der Bibliothek "Microsoft ActiveX Data Objects" in Ihrem Projekt):

Public Function URLEncode( _
   ByVal StringVal As String, _
   Optional SpaceAsPlus As Boolean = False _
) As String
  Dim bytes() As Byte, b As Byte, i As Integer, space As String

  If SpaceAsPlus Then space = "+" Else space = "%20"

  If Len(StringVal) > 0 Then
    With New ADODB.Stream
      .Mode = adModeReadWrite
      .Type = adTypeText
      .Charset = "UTF-8"
      .Open
      .WriteText StringVal
      .Position = 0
      .Type = adTypeBinary
      .Position = 3 ' skip BOM
      bytes = .Read
    End With

    ReDim result(UBound(bytes)) As String

    For i = UBound(bytes) To 0 Step -1
      b = bytes(i)
      Select Case b
        Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
          result(i) = Chr(b)
        Case 32
          result(i) = space
        Case 0 To 15
          result(i) = "%0" & Hex(b)
        Case Else
          result(i) = "%" & Hex(b)
      End Select
    Next i

    URLEncode = Join(result, "")
  End If
End Function

Diese Funktion wurde auf freevbcode.com gefunden :

Public Function URLEncode( _
   StringToEncode As String, _
   Optional UsePlusRatherThanHexForSpace As Boolean = False _
) As String

  Dim TempAns As String
  Dim CurChr As Integer
  CurChr = 1

  Do Until CurChr - 1 = Len(StringToEncode)
    Select Case Asc(Mid(StringToEncode, CurChr, 1))
      Case 48 To 57, 65 To 90, 97 To 122
        TempAns = TempAns & Mid(StringToEncode, CurChr, 1)
      Case 32
        If UsePlusRatherThanHexForSpace = True Then
          TempAns = TempAns & "+"
        Else
          TempAns = TempAns & "%" & Hex(32)
        End If
      Case Else
        TempAns = TempAns & "%" & _
          Right("0" & Hex(Asc(Mid(StringToEncode, _
          CurChr, 1))), 2)
    End Select

    CurChr = CurChr + 1
  Loop

  URLEncode = TempAns
End Function

Ich habe einen kleinen Fehler behoben, der dort drin war.

Ich würde eine effizientere (~ 2 × so schnelle) Version der oben genannten verwenden:

Public Function URLEncode( _
   StringVal As String, _
   Optional SpaceAsPlus As Boolean = False _
) As String

  Dim StringLen As Long: StringLen = Len(StringVal)

  If StringLen > 0 Then
    ReDim result(StringLen) As String
    Dim i As Long, CharCode As Integer
    Dim Char As String, Space As String

    If SpaceAsPlus Then Space = "+" Else Space = "%20"

    For i = 1 To StringLen
      Char = Mid$(StringVal, i, 1)
      CharCode = Asc(Char)
      Select Case CharCode
        Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
          result(i) = Char
        Case 32
          result(i) = Space
        Case 0 To 15
          result(i) = "%0" & Hex(CharCode)
        Case Else
          result(i) = "%" & Hex(CharCode)
      End Select
    Next i
    URLEncode = Join(result, "")
  End If
End Function

Beachten Sie, dass keine dieser beiden Funktionen die UTF-8-Codierung unterstützt.

Tomalak
quelle
5
Ich habe Ihre "effizientere (~ 2 × so schnelle) Version" verwendet und es funktioniert ein Vergnügen! Vielen Dank.
Chris Jacob
@ Chris Danke. :) Beachten Sie, dass Sie wahrscheinlich eine UTF-8-kompatible Version erstellen können, wenn Sie ein ADODB.StreamObjekt verwenden, das die erforderliche Zeichenfolgenkonvertierung durchführen kann. Beispiele für die Herstellung von UTF-8 mit VBA oder VBScript finden Sie im Internet.
Tomalak
Wenn die Leistung ein Problem darstellt, sollten Sie ein Refactoring in Betracht ziehen, um "Ersetzen" zu verwenden, indem Sie die Ganzzahl 0 bis 255 durchlaufen und Folgendes tun: Fall 0 bis 36, 38 bis 47, 58 bis 64, 91 bis 96, 123 bis 255 str_Input = Ersetzen (str_Input , Chr (int_char_num), "%" & Right ("0" & ​​Hex (255), 2))
Spioter
1
Das würde eigentlich das Gegenteil bewirken. VB-Zeichenfolgen sind unveränderlich. Wenn Sie 255 Mal ersetzen, wird bei jedem Schritt der Iteration eine neue, vollständige Zeichenfolge zugewiesen. Das ist in Bezug auf Speicherplatz und Speicher sicherlich verschwenderischer als das Zuweisen von Buchstaben zu einem vorab zugewiesenen Array.
Tomalak
Dieser Code stoppt bei einem Unicode-Fehler in Access 2013, da sowohl zu viele als auch zu wenige Zeichen gleichzeitig verarbeitet werden.
Henrik Erlandsson
50

Um dies auf den neuesten Stand zu bringen, gibt es seit Excel 2013 eine integrierte Methode zum Codieren von URLs mithilfe der Arbeitsblattfunktion ENCODEURL.

Um es in Ihrem VBA-Code zu verwenden, müssen Sie nur anrufen

EncodedUrl = WorksheetFunction.EncodeUrl(InputString)

Dokumentation

Jamie Bull
quelle
Es schlägt für mich fehl, wenn ich CSV-Daten mit aufeinanderfolgenden Kommas im Feld codieren muss. Ich musste die obige utf8-Version in der Antwort verwenden
Salman Siddique
@ SalmanSiddique gut, um die Einschränkungen zu kennen. Es könnte sich lohnen zu sagen, welche der utf8-Versionen Sie verwendet haben, da es mehr als eine gibt
Jamie Bull
Application.WorksheetFunction.EncodeUrl(myString)funktionierte perfekt für meine Bedürfnisse - hoffentlich wird diese Antwort genug positiv bewertet, um die vorherige, mega-alte Version zu
ersetzen
@ Jamheadart um fair zu sein, diese Antwort ist in der ersten Zeile der akzeptierten Antwort verlinkt
Jamie Bull
1
Das ist fair. Ich habe es nicht bemerkt. Ich sah die immense Menge an Code und das Datum und dachte, dass es weiter unten eine bessere Antwort geben würde!
Jamheadart
33

Version des oben genannten unterstützenden UTF8:

Private Const CP_UTF8 = 65001

#If VBA7 Then
  Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As LongPtr, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As LongPtr, _
    ByVal cbMultiByte As Long, _
    ByVal lpDefaultChar As Long, _
    ByVal lpUsedDefaultChar As Long _
    ) As Long
#Else
  Private Declare Function WideCharToMultiByte Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As Long, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As Long, _
    ByVal cbMultiByte As Long, _
    ByVal lpDefaultChar As Long, _
    ByVal lpUsedDefaultChar As Long _
    ) As Long
#End If

Public Function UTF16To8(ByVal UTF16 As String) As String
Dim sBuffer As String
Dim lLength As Long
If UTF16 <> "" Then
    #If VBA7 Then
        lLength = WideCharToMultiByte(CP_UTF8, 0, CLngPtr(StrPtr(UTF16)), -1, 0, 0, 0, 0)
    #Else
        lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0)
    #End If
    sBuffer = Space$(lLength)
    #If VBA7 Then
        lLength = WideCharToMultiByte(CP_UTF8, 0, CLngPtr(StrPtr(UTF16)), -1, CLngPtr(StrPtr(sBuffer)), LenB(sBuffer), 0, 0)
    #Else
        lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), LenB(sBuffer), 0, 0)
    #End If
    sBuffer = StrConv(sBuffer, vbUnicode)
    UTF16To8 = Left$(sBuffer, lLength - 1)
Else
    UTF16To8 = ""
End If
End Function

Public Function URLEncode( _
   StringVal As String, _
   Optional SpaceAsPlus As Boolean = False, _
   Optional UTF8Encode As Boolean = True _
) As String

Dim StringValCopy As String: StringValCopy = IIf(UTF8Encode, UTF16To8(StringVal), StringVal)
Dim StringLen As Long: StringLen = Len(StringValCopy)

If StringLen > 0 Then
    ReDim Result(StringLen) As String
    Dim I As Long, CharCode As Integer
    Dim Char As String, Space As String

  If SpaceAsPlus Then Space = "+" Else Space = "%20"

  For I = 1 To StringLen
    Char = Mid$(StringValCopy, I, 1)
    CharCode = Asc(Char)
    Select Case CharCode
      Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
        Result(I) = Char
      Case 32
        Result(I) = Space
      Case 0 To 15
        Result(I) = "%0" & Hex(CharCode)
      Case Else
        Result(I) = "%" & Hex(CharCode)
    End Select
  Next I
  URLEncode = Join(Result, "")

End If
End Function

Genießen!

Tom
quelle
3
Es ist nicht sinnvoll, in einer Antwort, die je nach Anzahl der Stimmen steigen oder fallen kann, auf das oben Gesagte zu verweisen.
Kometenschnabel
Jetzt braucht es VBA7Header mit PtrSafeund LongPtr.
John Alexiou
17

Obwohl dieser sehr alt ist. Ich habe eine Lösung gefunden, die auf dieser Antwort basiert :

Dim ScriptEngine As ScriptControl
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"

ScriptEngine.AddCode "function encode(str) {return encodeURIComponent(str);}"
Dim encoded As String
encoded = ScriptEngine.Run("encode", "€ömE.sdfds")

Fügen Sie Microsoft Script Control als Referenz hinzu und Sie sind fertig.

Nur eine Randnotiz: Aufgrund des JS-Teils ist dies vollständig UTF-8-kompatibel. VB konvertiert korrekt von UTF-16 nach UTF-8.

Michael-O
quelle
1
Genial, ich wusste nicht, dass Sie JS-Code in VBA verwenden können. Meine ganze Welt öffnet sich jetzt.
livefree75
1
Toll. Es war genau das, was ich brauche. Anmerkung: Wenn Sie keine Referenz hinzufügen möchten, können Sie: A) ScriptEngine als Objekt dimmen B) ScriptEngine = CreateObject ("scriptcontrol") setzen. Übrigens, anstatt eine Funktion in JS zu erstellen, können Sie die encodeURIComponent anscheinend sofort wie folgt aufrufen: encoded = ScriptEngine.Run ("encodeURIComponent", str)
El Scripto
@ ElScripto, mach weiter und poste eine verbesserte Antwort, die sich auf meine bezieht.
Michael-O
ScriptControl funktioniert nicht mit 64-Bit-Office-Versionen. Überprüfen Sie die Lösung über htmlfileActiveX und umgehen Sie das Problem, damit ScriptControl mit Excel x64 funktioniert .
Omegastripes
17

Ähnlich wie der Code von Michael-O, nur ohne Referenz (späte Bindung) und mit weniger einer Zeile.
* Ich habe gelesen, dass es in Excel 2013 einfacher geht: WorksheetFunction.EncodeUrl (InputString)

Public Function encodeURL(str As String)
    Dim ScriptEngine As Object
    Dim encoded As String

    Set ScriptEngine = CreateObject("scriptcontrol")
    ScriptEngine.Language = "JScript"

    encoded = ScriptEngine.Run("encodeURIComponent", str)

    encodeURL = encoded
End Function
El Scripto
quelle
ScriptControl funktioniert nicht mit 64-Bit-Office-Versionen. Überprüfen Sie die Lösung über htmlfileActiveX und umgehen Sie das Problem, damit ScriptControl mit Excel x64 funktioniert .
Omegastripes
13

Verwenden Sie seit Office 2013 diese eingebaute Funktion hier .

Wenn vor dem Amt 2013

Function encodeURL(str As String)
Dim ScriptEngine As ScriptControl
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"

ScriptEngine.AddCode "function encode(str) {return encodeURIComponent(str);}"
Dim encoded As String


encoded = ScriptEngine.Run("encode", str)
encodeURL = encoded
End Function

Fügen Sie Microsoft Script Control als Referenz hinzu und Sie sind fertig.

Gleich wie im letzten Beitrag nur komplette Funktion ..works!

Ozmike
quelle
Erledigt. Ok, ich wusste nicht, dass ich bearbeiten kann und du bekommst leider keine Punkte für Änderungen!
Ozmike
1
Zu Ihrer Information Ich habe versucht, den anderen Beitrag zu aktualisieren, aber meine Änderungen werden moderiert! z.B. Micha hat dies vor 18 Stunden überprüft: Ablehnen Diese Bearbeitung ist falsch oder ein Versuch, auf den vorhandenen Beitrag zu antworten oder ihn zu kommentieren. alex2410 hat dies vor 18 Stunden überprüft: Ablehnen Diese Bearbeitung ist falsch oder ein Versuch, auf den vorhandenen Beitrag zu antworten oder ihn zu kommentieren. bansi hat dies vor 18 Stunden überprüft: Ablehnen Diese Bearbeitung ist falsch oder ein Versuch, auf den vorhandenen Beitrag zu antworten oder ihn zu kommentieren. -
Ozmike
ScriptControl funktioniert nicht mit 64-Bit-Office-Versionen. Überprüfen Sie die Lösung über htmlfileActiveX und umgehen Sie das Problem, damit ScriptControl mit Excel x64 funktioniert .
Omegastripes
6

Eine weitere Lösung über htmlfileActiveX:

Function EncodeUriComponent(strText)
    Static objHtmlfile As Object
    If objHtmlfile Is Nothing Then
        Set objHtmlfile = CreateObject("htmlfile")
        objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
    End If
    EncodeUriComponent = objHtmlfile.parentWindow.encode(strText)
End Function

Das Deklarieren des htmlfileDOM-Dokumentobjekts als statische Variable gibt die einzige kleine Verzögerung beim ersten Aufruf aufgrund von init und macht diese Funktion für zahlreiche Aufrufe sehr schnell, z. B. konvertiert sie für mich die Zeichenfolge mit einer Länge von 100 Zeichen 100000 Mal in ca. 2 Sekunden.

Omegastripes
quelle
Upvote für statische. Es ist eine brillante Idee, es mit spät bindenden Unterprozeduren und Funktionen zu verwenden, die mehrfach aufgerufen werden, um die Dinge zu beschleunigen.
Ryszard Jędraszyk
1
@ RyszardJędraszyk Statickann für den gleichen Zweck auch mit früher Bindung verwendet werden.
Omegastripes
4

(Auf einen alten Faden stoßen). Hier ist eine Version, die Zeiger verwendet, um die Ergebniszeichenfolge zusammenzusetzen. Es ist ungefähr 2x - 4x so schnell wie die schnellere zweite Version in der akzeptierten Antwort.

Public Declare PtrSafe Sub Mem_Copy Lib "kernel32" _
    Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Public Declare PtrSafe Sub Mem_Read2 Lib "msvbvm60" _
    Alias "GetMem2" (ByRef Source As Any, ByRef Destination As Any)

Public Function URLEncodePart(ByRef RawURL As String) As String

    Dim pChar As LongPtr, iChar As Integer, i As Long
    Dim strHex As String, pHex As LongPtr
    Dim strOut As String, pOut As LongPtr
    Dim pOutStart As LongPtr, pLo As LongPtr, pHi As LongPtr
    Dim lngLength As Long
    Dim cpyLength As Long
    Dim iStart As Long

    pChar = StrPtr(RawURL)
    If pChar = 0 Then Exit Function

    lngLength = Len(RawURL)
    strOut = Space(lngLength * 3)
    pOut = StrPtr(strOut)
    pOutStart = pOut
    strHex = "0123456789ABCDEF"
    pHex = StrPtr(strHex)

    iStart = 1
    For i = 1 To lngLength
        Mem_Read2 ByVal pChar, iChar
        Select Case iChar
            Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
              ' Ok
            Case Else
                If iStart < i Then
                    cpyLength = (i - iStart) * 2
                    Mem_Copy ByVal pOut, ByVal pChar - cpyLength, cpyLength
                    pOut = pOut + cpyLength
                End If

                pHi = pHex + ((iChar And &HF0) / 8)
                pLo = pHex + 2 * (iChar And &HF)

                Mem_Read2 37, ByVal pOut
                Mem_Read2 ByVal pHi, ByVal pOut + 2
                Mem_Read2 ByVal pLo, ByVal pOut + 4
                pOut = pOut + 6

                iStart = i + 1
        End Select
        pChar = pChar + 2
    Next

    If iStart <= lngLength Then
        cpyLength = (lngLength - iStart + 1) * 2
        Mem_Copy ByVal pOut, ByVal pChar - cpyLength, cpyLength
        pOut = pOut + cpyLength
    End If

    URLEncodePart = Left$(strOut, (pOut - pOutStart) / 2)

End Function
Joshua Honig
quelle
2

Gleich wie WorksheetFunction.EncodeUrlbei der UTF-8-Unterstützung:

Public Function EncodeURL(url As String) As String
  Dim buffer As String, i As Long, c As Long, n As Long
  buffer = String$(Len(url) * 12, "%")

  For i = 1 To Len(url)
    c = AscW(Mid$(url, i, 1)) And 65535

    Select Case c
      Case 48 To 57, 65 To 90, 97 To 122, 45, 46, 95  ' Unescaped 0-9A-Za-z-._ '
        n = n + 1
        Mid$(buffer, n) = ChrW(c)
      Case Is <= 127            ' Escaped UTF-8 1 bytes U+0000 to U+007F '
        n = n + 3
        Mid$(buffer, n - 1) = Right$(Hex$(256 + c), 2)
      Case Is <= 2047           ' Escaped UTF-8 2 bytes U+0080 to U+07FF '
        n = n + 6
        Mid$(buffer, n - 4) = Hex$(192 + (c \ 64))
        Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
      Case 55296 To 57343       ' Escaped UTF-8 4 bytes U+010000 to U+10FFFF '
        i = i + 1
        c = 65536 + (c Mod 1024) * 1024 + (AscW(Mid$(url, i, 1)) And 1023)
        n = n + 12
        Mid$(buffer, n - 10) = Hex$(240 + (c \ 262144))
        Mid$(buffer, n - 7) = Hex$(128 + ((c \ 4096) Mod 64))
        Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
        Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
      Case Else                 ' Escaped UTF-8 3 bytes U+0800 to U+FFFF '
        n = n + 9
        Mid$(buffer, n - 7) = Hex$(224 + (c \ 4096))
        Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
        Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
    End Select
  Next

  EncodeURL = Left$(buffer, n)
End Function
Florent B.
quelle
1

Der Code der akzeptierten Antwort wurde aufgrund eines Unicode-Fehlers in Access 2013 gestoppt. Daher habe ich eine Funktion für mich mit hoher Lesbarkeit geschrieben, die laut Davis Peixoto RFC 3986 folgen und in verschiedenen Umgebungen nur minimale Probleme verursachen sollte.

Hinweis: Das Prozentzeichen selbst muss zuerst ersetzt werden, da sonst alle zuvor codierten Zeichen doppelt codiert werden. Das Ersetzen von Speicherplatz durch + wurde hinzugefügt, um nicht RFC 3986 zu entsprechen, sondern um Links bereitzustellen, die aufgrund der Formatierung nicht beschädigt werden. Es ist optional.

Public Function URLEncode(str As Variant) As String
    Dim i As Integer, sChar() As String, sPerc() As String
    sChar = Split("%|!|*|'|(|)|;|:|@|&|=|+|$|,|/|?|#|[|]| ", "|")
    sPerc = Split("%25 %21 %2A %27 %28 %29 %3B %3A %40 %26 %3D %2B %24 %2C %2F %3F %23 %5B %5D +", " ")
    URLEncode = Nz(str)
    For i = 0 To 19
        URLEncode = Replace(URLEncode, sChar(i), sPerc(i))
    Next i
End Function
Henrik Erlandsson
quelle
0

Wenn Sie möchten, dass es auch auf MacOs funktioniert, erstellen Sie eine separate Funktion

Function macUriEncode(value As String) As String

    Dim script As String
    script = "do shell script " & """/usr/bin/python -c 'import sys, urllib; print urllib.quote(sys.argv[1])' """ & Chr(38) & " quoted form of """ & value & """"

    macUriEncode = MacScript(script)

End Function
Paul
quelle
0

Ich hatte Probleme beim Codieren von kyrillischen Buchstaben in URF-8.

Ich habe eines der oben genannten Skripte so geändert, dass es mit der Karte der kyrillischen Zeichen übereinstimmt. Impliziert ist der kyrrile Abschnitt von

https://en.wikipedia.org/wiki/UTF-8 und http://www.utf8-chartable.de/unicode-utf8-table.pl?start=1024

Die Entwicklung anderer Abschnitte ist ein Beispiel und muss mit realen Daten überprüft und die Char-Map-Offsets berechnet werden

Hier ist das Skript: 

Public Function UTF8Encode( _
   StringToEncode As String, _
   Optional UsePlusRatherThanHexForSpace As Boolean = False _
) As String

  Dim TempAns As String
  Dim TempChr As Long
  Dim CurChr As Long
  Dim Offset As Long
  Dim TempHex As String
  Dim CharToEncode As Long
  Dim TempAnsShort As String

  CurChr = 1

  Do Until CurChr - 1 = Len(StringToEncode)
    CharToEncode = Asc(Mid(StringToEncode, CurChr, 1))
' http://www.utf8-chartable.de/unicode-utf8-table.pl?start=1024
' as per https://en.wikipedia.org/wiki/UTF-8 specification the engoding is as follows

    Select Case CharToEncode
'   7   U+0000 U+007F 1 0xxxxxxx
      Case 48 To 57, 65 To 90, 97 To 122
        TempAns = TempAns & Mid(StringToEncode, CurChr, 1)
      Case 32
        If UsePlusRatherThanHexForSpace = True Then
          TempAns = TempAns & "+"
        Else
          TempAns = TempAns & "%" & Hex(32)
        End If
      Case 0 To &H7F
            TempAns = TempAns + "%" + Hex(CharToEncode And &H7F)
      Case &H80 To &H7FF
'   11  U+0080 U+07FF 2 110xxxxx 10xxxxxx
' The magic is in offset calculation... there are different offsets between UTF-8 and Windows character maps
' offset 192 = &HC0 = 1100 0000 b  added to start of UTF-8 cyrillic char map at &H410
          CharToEncode = CharToEncode - 192 + &H410
          TempAnsShort = "%" & Right("0" & Hex((CharToEncode And &H3F) Or &H80), 2)
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40) And &H1F) Or &HC0), 2) & TempAnsShort
          TempAns = TempAns + TempAnsShort

'' debug and development version
''          CharToEncode = CharToEncode - 192 + &H410
''          TempChr = (CharToEncode And &H3F) Or &H80
''          TempHex = Hex(TempChr)
''          TempAnsShort = "%" & Right("0" & TempHex, 2)
''          TempChr = ((CharToEncode And &H7C0) / &H40) Or &HC0
''          TempChr = ((CharToEncode \ &H40) And &H1F) Or &HC0
''          TempHex = Hex(TempChr)
''          TempAnsShort = "%" & Right("0" & TempHex, 2) & TempAnsShort
''          TempAns = TempAns + TempAnsShort

      Case &H800 To &HFFFF
'   16 U+0800 U+FFFF 3 1110xxxx 10xxxxxx 10xxxxxx
' not tested . Doesnot match Case condition... very strange
        MsgBox ("Char to encode  matched U+0800 U+FFFF: " & CharToEncode & " = &H" & Hex(CharToEncode))
''          CharToEncode = CharToEncode - 192 + &H410
          TempAnsShort = "%" & Right("0" & Hex((CharToEncode And &H3F) Or &H80), 2)
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H1000) And &HF) Or &HE0), 2) & TempAnsShort
          TempAns = TempAns + TempAnsShort

      Case &H10000 To &H1FFFFF
'   21 U+10000 U+1FFFFF 4 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
''        MsgBox ("Char to encode  matched &H10000 &H1FFFFF: " & CharToEncode & " = &H" & Hex(CharToEncode))
' sample offset. tobe verified
          CharToEncode = CharToEncode - 192 + &H410
          TempAnsShort = "%" & Right("0" & Hex((CharToEncode And &H3F) Or &H80), 2)
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H1000) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40000) And &H7) Or &HF0), 2) & TempAnsShort
          TempAns = TempAns + TempAnsShort

      Case &H200000 To &H3FFFFFF
'   26  U+200000 U+3FFFFFF 5 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
''        MsgBox ("Char to encode  matched U+200000 U+3FFFFFF: " & CharToEncode & " = &H" & Hex(CharToEncode))
' sample offset. tobe verified
          CharToEncode = CharToEncode - 192 + &H410
          TempAnsShort = "%" & Right("0" & Hex((CharToEncode And &H3F) Or &H80), 2)
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H1000) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40000) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H1000000) And &H3) Or &HF8), 2) & TempAnsShort
          TempAns = TempAns + TempAnsShort

      Case &H4000000 To &H7FFFFFFF
'   31  U+4000000 U+7FFFFFFF 6 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
''        MsgBox ("Char to encode  matched U+4000000 U+7FFFFFFF: " & CharToEncode & " = &H" & Hex(CharToEncode))
' sample offset. tobe verified
          CharToEncode = CharToEncode - 192 + &H410
          TempAnsShort = "%" & Right("0" & Hex((CharToEncode And &H3F) Or &H80), 2)
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H1000) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40000) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H1000000) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40000000) And &H1) Or &HFC), 2) & TempAnsShort
          TempAns = TempAns + TempAnsShort

      Case Else
' somethig else
' to be developped
        MsgBox ("Char to encode not matched: " & CharToEncode & " = &H" & Hex(CharToEncode))

    End Select

    CurChr = CurChr + 1
  Loop

  UTF8Encode = TempAns
End Function

Viel Glück!

ndd
quelle
0

Dieses Snippet, das ich in meiner Anwendung zum Codieren der URL verwendet habe, kann Ihnen dabei helfen, dasselbe zu tun. 

Function URLEncode(ByVal str As String) As String
        Dim intLen As Integer
        Dim x As Integer
        Dim curChar As Long
        Dim newStr As String
        intLen = Len(str)
        newStr = ""

        For x = 1 To intLen
            curChar = Asc(Mid$(str, x, 1))

            If (curChar < 48 Or curChar > 57) And _
                (curChar < 65 Or curChar > 90) And _
                (curChar < 97 Or curChar > 122) Then
                                newStr = newStr & "%" & Hex(curChar)
            Else
                newStr = newStr & Chr(curChar)
            End If
        Next x

        URLEncode = newStr
    End Function
Jimit Rupani
quelle
0

Keine der Lösungen hier funktionierte sofort für mich, aber es lag höchstwahrscheinlich an meiner mangelnden Erfahrung mit VBA. Dies kann auch daran liegen, dass ich einige der oben genannten Funktionen einfach kopiert und eingefügt habe, ohne die Details zu kennen, die möglicherweise erforderlich sind, damit sie in einer VBA für Anwendungsumgebung funktionieren.

Meine Bedürfnisse waren einfach, xmlhttp-Anfragen mit URLs zu senden, die einige Sonderzeichen der norwegischen Sprache enthielten. Einige der oben genannten Lösungen codieren sogar Doppelpunkte, wodurch die URLs für das, was ich brauchte, ungeeignet waren.

Ich habe mich dann entschlossen, meine eigene URLEncode-Funktion zu schreiben. Es verwendet keine cleverere Programmierung wie die von @ndd und @Tom. Ich bin kein sehr erfahrener Programmierer, aber ich musste dies früher erledigen.

Ich stellte fest, dass das Problem darin bestand, dass mein Server keine UTF-16-Codierungen akzeptierte, sodass ich eine Funktion schreiben musste, die UTF-16 in UTF-8 konvertierte. Hier und hier wurde eine gute Informationsquelle gefunden .

Ich habe es nicht ausgiebig getestet, um zu überprüfen, ob es mit URLs mit Zeichen funktioniert, die höhere Unicode-Werte haben und mehr als 2 Byte utf-8-Zeichen erzeugen würden. Ich sage nicht, dass es alles dekodiert, was dekodiert werden muss (aber es ist einfach zu ändern, um Zeichen in die select caseAnweisung aufzunehmen / auszuschließen ), noch dass es mit höheren Zeichen funktioniert, da ich nicht vollständig getestet habe. Aber ich teile den Code, weil er jemandem helfen könnte, der versucht, das Problem zu verstehen.

Kommentare sind willkommen.

Public Function URL_Encode(ByVal st As String) As String

    Dim eachbyte() As Byte
    Dim i, j As Integer 
    Dim encodeurl As String
    encodeurl = "" 

    eachbyte() = StrConv(st, vbFromUnicode)

    For i = 0 To UBound(eachbyte)

        Select Case eachbyte(i)
        Case 0
        Case 32
            encodeurl = encodeurl & "%20"

        ' I am not encoding the lower parts, not necessary for me
        Case 1 To 127
            encodeurl = encodeurl & Chr(eachbyte(i))
        Case Else

            Dim myarr() As Byte
            myarr = utf16toutf8(eachbyte(i))
            For j = LBound(myarr) To UBound(myarr) - 1
                encodeurl = encodeurl & "%" & Hex(myarr(j))
            Next j
        End Select
    Next i
    URL_Encode = encodeurl 
End Function

Public Function utf16toutf8(ByVal thechars As Variant) As Variant
    Dim numbytes As Integer
    Dim byte1 As Byte
    Dim byte2 As Byte
    Dim byte3 As Byte
    Dim byte4 As Byte
    Dim byte5 As Byte 
    Dim i As Integer  
    Dim temp As Variant
    Dim stri As String

    byte1 = 0
    byte2 = byte3 = byte4 = byte5 = 128

    ' Test to see how many bytes the utf-8 char will need
    Select Case thechars
        Case 0 To 127
            numbytes = 1
        Case 128 To 2047
            numbytes = 2
        Case 2048 To 65535
            numbytes = 3
        Case 65536 To 2097152
            numbytes = 4
        Case Else
            numbytes = 5
    End Select

    Dim returnbytes() As Byte
    ReDim returnbytes(numbytes)


    If numbytes = 1 Then
        returnbytes(0) = thechars
        GoTo finish
    End If


    ' prepare the first byte
    byte1 = 192

    If numbytes > 2 Then
        For i = 3 To numbytes
            byte1 = byte1 / 2
            byte1 = byte1 + 128
        Next i
    End If
    temp = 0
    stri = ""
    If numbytes = 5 Then
        temp = thechars And 63

        byte5 = temp + 128
        returnbytes(4) = byte5
        thechars = thechars / 12
        stri = byte5
    End If

    If numbytes >= 4 Then

        temp = 0
        temp = thechars And 63
        byte4 = temp + 128
        returnbytes(3) = byte4
        thechars = thechars / 12
        stri = byte4 & stri
    End If

    If numbytes >= 3 Then

        temp = 0
        temp = thechars And 63
        byte3 = temp + 128
        returnbytes(2) = byte3
        thechars = thechars / 12
        stri = byte3 & stri
    End If

    If numbytes >= 2 Then

        temp = 0
        temp = thechars And 63
        byte2 = temp Or 128
        returnbytes(1) = byte2
        thechars = Int(thechars / (2 ^ 6))
        stri = byte2 & stri
    End If

    byte1 = thechars Or byte1
    returnbytes(0) = byte1

    stri = byte1 & stri

    finish:
       utf16toutf8 = returnbytes()
End Function
francisaugusto
quelle