Как я могу URL-адресно закодировать строку в Excel VBA?
Вопрос
Есть ли встроенный способ URL-кодирования строки в Excel VBA или мне нужно вручную выполнить эту функциональность?
Решение
Нет, ничего встроенного (до Excel 2013 - смотрите этот ответ).
Существует три версии URLEncode()
в этом ответе.
- Функция с поддержкой UTF-8. Вероятно, вам следует воспользоваться этим (или альтернативная реализация by Tom) для совместимости с современными требованиями.
- Для справочных и образовательных целей используются две функции без поддержки UTF-8:
- один найден на стороннем веб-сайте, включен как есть.(Это была первая версия ответа)
- одна оптимизированная версия этого, написанная мной
Вариант, поддерживающий кодировку UTF-8 и основанный на ADODB.Stream
(включите в свой проект ссылку на последнюю версию библиотеки "Microsoft ActiveX Data Objects"):
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
Эта функция была найдено на 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
Я исправил небольшую ошибку, которая была там.
Я бы использовал более эффективную (~ в 2 раза быстрее) версию вышеописанного:
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
Обратите внимание, что ни одна из этих двух функций не поддерживает кодировку UTF-8.
Другие советы
В целях повышения актуальности этой версии, начиная с Excel 2013, теперь существует встроенный способ кодирования URL-адресов с использованием функции листа ENCODEURL
.
Чтобы использовать его в своем коде VBA, вам просто нужно позвонить
EncodedUrl = WorksheetFunction.EncodeUrl(InputString)
Версия, описанная выше, поддерживающая 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
Наслаждайтесь!
Хотя этот очень старый. Я нашел решение, основанное на этом ответе:
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")
Добавьте Microsoft Script Control в качестве ссылки, и все готово.
Просто примечание: из-за части JS она полностью совместима с UTF-8. VB будет правильно конвертировать из UTF-16 в UTF-8.
Аналогично коду Michael-O, только без ссылки (с поздним связыванием) и с одной строкой меньше.
* Я читал, что в Excel 2013 это можно сделать проще, например:
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
Начиная с Office 2013, используйте эту встроенную функцию здесь .
Если до офиса 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
Добавьте Microsoft Script Control в качестве ссылки, и все готово. Р>
То же, что и в предыдущем посте, просто завершите функцию ..works!
Еще одно решение с помощью 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
Объявление htmlfile
объекта документа DOM в качестве статической переменной дает единственную небольшую задержку при первом вызове из-за init и делает эту функцию очень быстрой для многочисленных вызовов, e. г. для меня он преобразует строку из 100 символов длиной 100000 раз за 2 секунды.
(Поднять старую ветку). Просто для удовольствия, вот версия, которая использует указатели для сборки строки результата. Это примерно в 2-4 раза быстрее, чем вторая версия принятого ответа.
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
То же, что и WorksheetFunction.EncodeUrl
с поддержкой 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
Если вы также хотите, чтобы он работал на MacO, создайте отдельную функцию
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
У меня была проблема с кодированием букв кириллицы в URF-8. Р>
Я изменил один из приведенных выше сценариев, чтобы он соответствовал карте кириллицы. Реализована кириллица
https://en.wikipedia.org/wiki/UTF-8 а также http://www.utf8-chartable.de/unicode-utf8 -table.pl?start=1024 р>
Разработка других разделов является образцом и требует проверки с помощью реальных данных и расчета смещений карты символов
Вот сценарий:
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
Удачи!
Этот фрагмент, который я использовал в своем приложении для кодирования URL, может помочь вам сделать то же самое. Р>
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
Ни одно из предложенных здесь решений не работало для меня из коробки, но, скорее всего, это было связано с моим отсутствием опыта работы с VBA. Это также может быть связано с тем, что я просто скопировал и вставил некоторые из перечисленных выше функций, не зная деталей, которые, возможно, необходимы для их работы в среде VBA для приложений.
Мне нужно было просто отправлять запросы xmlhttp с помощью URL-адресов, содержащих некоторые специальные символы норвежского языка. Некоторые из приведенных выше решений кодируют даже двоеточия, что делает URL-адреса неподходящими для того, что мне нужно.
Затем я решил написать свою собственную функцию URLEncode. Он не использует более умное программирование, такое как @ndd и @Tom. Я не очень опытный программист, но мне пришлось сделать это раньше.
Я понял, что проблема в том, что мой сервер не принимает кодировки UTF-16, поэтому мне пришлось написать функцию, которая конвертирует UTF-16 в UTF-8. Хороший источник информации был найден здесь . и здесь .
Я не тестировал его всесторонне, чтобы проверить, работает ли он с URL-адресами с символами, которые имеют более высокие значения Юникода и которые выдают более 2 байтов символов utf-8. Я не говорю, что он будет декодировать все, что должно быть декодировано (но его легко изменить, чтобы включить / исключить символы в операторе select case
), а также что он будет работать с более старшими символами, как у меня есть не полностью протестирован. Но я делюсь кодом, потому что он может помочь кому-то, кто пытается понять проблему.
Любые комментарии приветствуются.
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
В библиотеке VBA-tools есть функция для этого:
http://vba-tools.github.io / VBA-Web / документы / # / WebHelpers / UrlEncode
Кажется, что он работает аналогично encodeURIComponent ()
в JavaScript.