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

Question

¿Existe una forma incorporada de codificación URL de una cadena en Excel VBA o necesito transferir esta funcionalidad manualmente?

Answer 1

No, nada incorporado (hasta Excel 2013 - see this answer).

Hay tres versiones de URLEncode() en esta respuesta.

• Una función con soporte UTF-8. Probablemente debería usar este (o the alternative implementation por Tom) para la compatibilidad con los requisitos modernos.
• A modo de referencia y con fines educativos, dos funciones sin soporte UTF-8:
  • que se encuentra en un sitio web de terceros, incluidos tal y como son. (Esta era la primera versión de la respuesta)
  • una versión optimizada de que, escrito por mí

---

Una variante que soporta codificación UTF-8 y se basa en ADODB.Stream (incluir una referencia a una versión reciente del "Microsoft ActiveX Data Objects" biblioteca en su proyecto):

Public Function URLEncode(_ 
    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 found on 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 error que estaba allí.

---

yo usaría más eficiente (~ 2 × tan rápido) de la versión 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 codificación UTF-8.

Answer 2

Versión del soporte UTF8 arriba:

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 

Enjoy!

Answer 3

Aunque, este es muy viejo. He llegado a una solución basada en this 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 Microsoft Script Control como referencia y ya está.

Solo una nota al margen, debido a la parte JS, esto es totalmente compatible con UTF-8. VB se convertirá correctamente de UTF-16 a UTF-8.

Answer 4

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 

Agregue Microsoft Script Control como referencia y listo.

Igual que la última publicación simplemente completa la función ..works!

Answer 5

(Golpe en un hilo viejo). Solo por las patadas, aquí hay una versión que usa punteros para ensamblar la cadena de resultados. Se trata de 2x - 4x tan rápido como la segunda versión más rápida en la respuesta aceptada.

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 = "ABCDEF" 
    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 

Answer 6

Si también desea que funcione en MacOS crear una función separada

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 

Answer 7

En aras de traer esto al día, ya que Excel 2013 ahora hay una forma integrada de la codificación URL que utilizan la función de hoja de cálculo ENCODEURL.

Para utilizarlo en su código VBA sólo tiene que llamar

EncodedUrl = WorksheetFunction.EncodeUrl(InputString) 

Documentation

Answer 8

similar al código de Michael-O, sólo que sin necesidad de hacer referencia a (finales se unen) y con menos de una línea.
* He leído, que en Excel 2013 se puede hacer más fácilmente de esta manera: 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 

Answer 9

tuve un problema con la codificación de caracteres cirílicos URF-8.

Modifiqué uno de los scripts anteriores para que coincida con el mapa de caracteres cirílicos. Implmented es la sección cyrrilic del desarrollo

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

Otras secciones se muestra y se necesita la verificación con los datos reales y calcular el mapa de carbón compensaciones

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!

Answer 10

Este fragmento lo he usado en mi aplicación para codificar la URL, así que puede ayudarte 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 

Answer 11

una solución más 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 DOM documento objeto como variable estática da la única pequeño retraso cuando se le llama por primera vez debido a init, y hace esta función muy rápido para numerosos llamadas, e. gramo. para mí convierte la cadena de 100 caracteres de longitud 100000 veces en 2 segundos aproximadamente ..

Answer 12

Ninguna de las soluciones aquí funcionó para mí de manera inmediata, pero probablemente se debió a mi falta de experiencia con VBA. También podría ser porque simplemente copié y pegué algunas de las funciones anteriores, sin conocer los detalles que tal vez sean necesarios para que funcionen en un VBA para entornos de aplicaciones.

Mis necesidades eran simplemente enviar solicitudes de xmlhttp usando urls que contenían algunos caracteres especiales del idioma noruego. Algunas de las soluciones anteriores codifican incluso dos puntos, lo que hacía que las URL no fueran adecuadas para lo que necesitaba.

Luego decidí escribir mi propia función URLEncode. No utiliza programación más inteligente como la de @ndd y @Tom. No soy un programador muy experimentado, pero tuve que hacer esto antes.

Me di cuenta de que el problema era que mi servidor no aceptaba codificaciones UTF-16, así que tuve que escribir una función que convertiría UTF-16 a UTF-8. Se encontró una buena fuente de información here y here.

No lo he probado extensamente para comprobar si funciona con url con caracteres que tienen valores unicode más altos y que produciría más de 2 bytes de caracteres utf-8. No estoy diciendo que decodificará todo lo que necesita decodificarse (pero es fácil modificar para incluir/excluir caracteres en la declaración select case) ni que funcionará con caracteres más altos, ya que no lo he probado por completo. Pero estoy compartiendo el código porque podría ayudar a alguien que intenta comprender 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