¿Cómo puedo URL codificar una cadena en VBA de Excel?

Es allí una manera integrada URL codificar una cadena en VBA de Excel o tengo a mano el rollo de esta funcionalidad?

14 Kommentare

  1. 80

    No, nada incorporado (hasta que Excel 2013 – ver esta respuesta).

    Hay tres versiones de URLEncode() en esta respuesta.

    • Una función con soporte para UTF-8. Usted probablemente debería usar este (o la implementación alternativa por Tom) para la compatibilidad con las exigencias modernas.
    • De referencia y con fines educativos, con dos funciones sin soporte para UTF-8:
      • una que se encuentra en un sitio web de terceros, incluidos como-es. (Esta fue la primera versión de la respuesta)
      • una versión optimizada de que, escrito por mí

    Una variante que soporta la codificación UTF-8 y se basa en ADODB.Stream (incluir una referencia a la versión más reciente de la «Microsoft ActiveX Data Objects» de la biblioteca en el proyecto):

    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

    Esta función fue se encuentran en freevbcode.com:

    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

    He corregido un pequeño bug que había allí.


    Yo uso más eficiente (~2× tan rápido) versión de la anterior:

    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

    Tenga en cuenta que ninguna de estas dos funciones de apoyo a la codificación UTF-8.

    • He utilizado la «más eficiente (~2× tan rápido) versión» y funciona de maravilla! Gracias.
    • Gracias. 🙂 Tomar nota de que, probablemente pueda hacer una UTF-8-versión compatible si utiliza un ADODB.Stream objeto, que puede hacer la necesaria conversión de cadena. Muestras de cómo producir UTF-8 con VBA o VBScript son todos a través de Internet.
    • si el rendimiento es un problema – considerar la refactorización para el uso de «reemplazar» por el ciclismo a través de un número entero de 0 a 255 y hacer algo como: Caso 0 A 36, 38 A 47, 58 A 64, 91 A 96, 123 255 str_Input = Replace(str_Input, Chr(int_char_num), «%» & a la Derecha(«0» & Hex(255), 2))
    • Que en realidad iba a hacer lo contrario. VB cadenas son inmutables, haciendo un reemplazo 255 veces en uno asigna una nueva cadena completa con cada paso de la iteración. Eso es, sin duda, más despilfarro en términos de memoria y espacio de la asignación de letras a un pre-asignados matriz.
  2. 38

    Por el bien de traer esto a la fecha, ya que Excel 2013 ahora hay un built-en la forma de codificación de Url utilizando la función de hoja de cálculo ENCODEURL.

    A utilizar en el código de VBA que sólo necesitan llamar a

    EncodedUrl = WorksheetFunction.EncodeUrl(InputString)

    Documentación

    • Gracias por la información actualizada!
    • No funciona para mí a la hora de codificar los datos csv con comas seguidas en el campo.. tuvo que usar la anterior utf8 versión en la respuesta
    • buena para conocer las limitaciones. Podría ser la pena decir que de la utf8 versiones que utilizan, ya que hay más de uno
    • el uno con ADODB.Secuencia de respuesta por tomalak..
    • Muchas gracias, que resolvió mi producción error!
    • Application.WorksheetFunction.EncodeUrl(myString) funcionó a la perfección para mis necesidades, espero que esta respuesta va a ser upvoted suficiente para sustituir a la anterior, mega-versión antigua
    • para ser justos, esta respuesta se vincula en la primera línea de la aceptó responder
    • Que es lo justo. Yo no me di cuenta. Vi la inmensa cantidad de código y la fecha y pensé que habría una mejor respuesta de más abajo!
    • WorksheetFunction(s) no funciona en Mac

  3. 31

    Versión de la anterior apoyar UTF8:

    Private Const CP_UTF8 = 65001  
    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 cchMultiByte As Long, 
        ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
    
    Public Function UTF16To8(ByVal UTF16 As String) As String
    Dim sBuffer As String
    Dim lLength As Long
    If UTF16 <> "" Then
        lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0)
        sBuffer = Space$(lLength)
        lLength = WideCharToMultiByte(
            CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), Len(sBuffer), 0, 0)
        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

    Disfrutar!

    • Hace referencia a ‘los de arriba’, en una respuesta que puede aumentar o fregadero, dependiendo del número de votos, no es útil.
    • Ahora ella necesita VBA7 encabezados con PtrSafe y LongPtr.
  4. 17

    Aunque, esta es muy vieja. He venido para arriba con una solución basada en este respuesta:

    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")

    Agregar secuencias de Comandos de Microsoft de Control como referencia y listo.

    Sólo una nota al margen, debido a la JS parte, esto es completamente UTF-8-compatible. VB va a convertir correctamente desde UTF-16 y UTF-8.

    • Impresionante, yo no sabía que se podía utilizar el código JS en VBA. Todo mi mundo se está abriendo ahora.
    • Gran. Era justo lo que necesitas. Nota: Si no desea agregar una referencia, usted puede: a) Dim ScriptEngine Como Objeto B) Establecer ScriptEngine = CreateObject(«control de secuencias de comandos»). Por el camino, en lugar de crear una función en JS, parece que usted puede llamar a la encodeURIComponent de inmediato así: codificado = ScriptEngine.Ejecutar(«encodeURIComponent», str)
    • adelante y publicar una mejora de la respuesta que se refiere a la mía.
    • Control de secuencias de comandos no funcionan en 64-bit versiones de Office, consulte la solución a través de htmlfile ActiveX y solución recibiendo control de secuencias de comandos para trabajar con Excel x64.
  5. 14

    Similar a Michael-O del código, sólo sin necesidad de hacer referencia (enlazar) y con menos de una línea .

    * He leído, que en excel 2013 se puede hacer más fácilmente así:
    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
  6. 13

    Desde office 2013 utilice esta función incorporada aquí.

    Si antes de office 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

    Agregar secuencias de Comandos de Microsoft de Control como referencia y listo.

    Mismo como último post completo ..funciona!

    • ¿Por qué no acaba de editar la otra respuesta?
    • Hecho. Ok yo no sabía que se podía editar y no obtiene puntos por ediciones por desgracia!
    • FYI traté de actualizar el otro post, pero mis ediciones obtener moderado! por ejemplo. Micha revisó este 18 horas: Rechazar Esta edición es incorrecta o un intento de respuesta o comentario en el correo existente. alex2410 revisó este 18 horas: Rechazar Esta edición es incorrecta o un intento de respuesta o comentario en el correo existente. bansi, un revisó este 18 horas: Rechazar Esta edición es incorrecta o un intento de respuesta o comentario en el correo existente. –
    • Control de secuencias de comandos no funcionan en 64-bit versiones de Office, consulte la solución a través de htmlfile ActiveX y solución recibiendo control de secuencias de comandos para trabajar con Excel x64.
  7. 6

    Uno más de la solución a través de htmlfile ActiveX:

    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

    Declarar htmlfile documento DOM objeto como una variable estática da la única pequeño retraso cuando se llama primera vez debido a init, y hace que esta función sea muy rápido para numerosas llamadas, correo. g. para mí se convierte la cadena de 100 caracteres de longitud 100000 veces en 2 segundos aprox..

    • Upvote para la estática. Es una idea genial para usarlo con el enlace sub-procedimientos y funciones, que se llama varias veces, para acelerar las cosas.
    • puede ser utilizado con los principios de unión, así como para el mismo propósito.
  8. 4

    (Golpe en un hilo viejo). Solo por curiosidad, hay una versión que utiliza punteros a montar la cadena de resultado. Se trata de 2x – 4x más rápido que el más rápido de la segunda versión en la aceptó respuesta.

    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
  9. 1

    Mismo como WorksheetFunction.EncodeUrl con soporte para UTF-8:

    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
  10. 0

    Si usted también quiere trabajar en MacOs crear una nueva función

    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
  11. 0

    He tenido problema con la codificación de caracteres cirílicos cartas a URF-8.

    He modificado uno de los scripts anteriores para que coincida con el cirílico char mapa.
    Implmented es el cyrrilic sección de

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

    Otras secciones de desarrollo de la muestra y la necesidad de verificación con datos reales y calcular el char mapa de desplazamientos

    Aquí está la secuencia de comandos:

    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

    Buena suerte!

  12. 0

    Este fragmento de código que he usado en mi aplicación para codificar la URL así que puede que esto puede ayudar a usted a hacer lo mismo.

    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
  13. 0

    Ninguna de las soluciones que aquí se trabajó para mí fuera de la caja, pero era más probable que se deba a mi falta de experiencia con VBA. También podría ser porque yo simplemente copiar y pegar algunas de las funciones anteriores, no conocer los detalles que tal vez sean necesarias para hacerlos trabajar en una VBA para aplicaciones de medio ambiente.

    Mis necesidades eran simplemente para enviar solicitudes xmlhttp el uso de las url que contiene algunos caracteres especiales del idioma noruego. Algunas de las soluciones anteriores codificar incluso de colones, lo que hizo la url inadecuado para lo que yo necesitaba.

    Entonces me decidí a escribir mi propia función URLEncode. No uso más inteligente de programación como el de @ddn y @Tom. Yo no soy un programador muy experimentado, pero yo tenía que hacer de este hecho antes.

    Me di cuenta de que el problema era que mi servidor no acepta codificaciones de UTF-16, así que tuve que escribir una función que iba a convertir a UTF-16 y UTF-8. Una buena fuente de información fue encontrada aquí y aquí.

    Yo no lo he probado extensivamente para comprobar si funciona con la url con caracteres que tienen mayores valores unicode y que producen más de 2 bytes de caracteres utf-8. No estoy diciendo que va a decodificar todo lo que necesita ser decodificado (pero es fácil de modificar para incluir/excluir de los personajes en la select case declaración), ni que va a trabajar con más personajes, como no he probado completamente. Pero estoy compartiendo el código ya que podría ayudar a alguien que está tratando de entender el problema.

    Cualquier comentario es bienvenido.

    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

Kommentieren Sie den Artikel

Bitte geben Sie Ihren Kommentar ein!
Bitte geben Sie hier Ihren Namen ein

Pruebas en línea