Як я можу кодувати рядок у Excel VBA?

Відповіді:

90

Ні, нічого вбудованого ( до Excel 2013 - див. Цю відповідь ).

У URLEncode()цій відповіді є три версії .

  • Функція з підтримкою UTF-8. Ймовірно, вам слід скористатися цим (або альтернативною реалізацією Тома) для сумісності з сучасними вимогами.
  • Для довідкових та навчальних цілей дві функції без підтримки 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.

— Томалак
джерело
5
Я використав вашу "більш ефективну (~ 2 × швидку) версію", і це чудово підходить! Дякую.
— Chris Jacob
@Chris Дякую. :) Зверніть увагу, що ви, ймовірно, можете зробити версію, сумісну з UTF-8, якщо ви використовуєте ADODB.Streamоб'єкт, який може виконати необхідне перетворення рядків. Зразки, як створювати UTF-8 за допомогою VBA або VBScript, є в Інтернеті.
— Томалак
якщо продуктивність є проблемою - розгляньте можливість рефакторингу для використання "заміни", прокрутивши цілі числа від 0 до 255 і зробивши щось на зразок: Випадок від 0 до 36, 38 до 47, 58 до 64, 91 до 96, 123 до 255 str_Input = Replace (str_Input , Chr (int_char_num), "%" & Right ("0" & ​​Hex (255), 2))
— spioter
1
Це насправді мало б навпаки. Рядки VB незмінні, замінюючи 255 разів, один виділяє новий, повний рядок з кожним кроком ітерації. Це, звичайно, більш марнотратно з точки зору місця та пам'яті, ніж присвоєння літер попередньо виділеному масиву.
— Томалак
Цей код зупиниться на помилці Unicode в Access 2013, оскільки він одночасно обробляє занадто багато і занадто мало символів.
— Генрік Ерландссон,
52

Задля оновлення цього, з Excel 2013 тепер вбудований спосіб кодування URL-адрес за допомогою функції робочого аркуша ENCODEURL.

Щоб використовувати його у коді VBA, вам просто потрібно зателефонувати

EncodedUrl = WorksheetFunction.EncodeUrl(InputString)

Документація

— Джеймі Булл
джерело
Мені це не вдається, коли доводиться кодувати дані CSV із послідовними комами в полі .. довелося використовувати вищезгадану версію utf8 у відповіді
— Сальман Сіддіке
@SalmanSiddique добре знати обмеження. Можливо, варто сказати, яку з версій utf8 ви використовували, оскільки існує більше однієї
— Джеймі Булл,
Application.WorksheetFunction.EncodeUrl(myString)працював ідеально для моїх потреб - сподіваюся, ця відповідь буде достатньо голосною, щоб замінити попередню, мега-стару версію
— jamheadart
@jamheadart, щоб бути справедливим, ця відповідь пов’язана з першим рядком прийнятої відповіді
— Jamie Bull
2
Це справедливо. Я цього не помітив. Я побачив величезну кількість коду і дату, і зрозумів, що далі буде краща відповідь!
— jamheadart
33

Версія вищезгаданої підтримки 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

Насолоджуйтесь!

— Том
джерело
4
Посилання на "вищезазначене" у відповіді, яка цілком може піднятися або опуститися залежно від кількості голосів, є корисним.
— cometbill
Тепер йому потрібні VBA7заголовки з PtrSafeта LongPtr.
— Джон Алексіу
17

Хоча, цей дуже старий. Я придумав рішення, засноване на цій відповіді:

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.

— Майкл-О
джерело
1
Чудово, я не знав, що ти можеш використовувати код JS у VBA. Зараз відкривається весь мій світ.
— livefree75
1
Чудово. Це було саме те, що мені потрібно. Примітка: Якщо ви не хочете додавати посилання, ви можете: A) Затемнити ScriptEngine як об'єкт B) Встановити ScriptEngine = CreateObject ("scriptcontrol"). До речі, замість того, щоб створювати функцію в JS, здається, ви можете викликати encodeURIComponent відразу так: encoded = ScriptEngine.Run ("encodeURIComponent", str)
— El Scripto 07.03.15
@ElScripto, продовжуй і публікуй вдосконалену відповідь, яка стосується моєї.
— Michael-O
1
ScriptControl не працюватиме у 64-розрядних версіях Office, перевіряти рішення через htmlfileActiveX та обходити спосіб отримання ScriptControl для роботи з Excel x64 .
— omegastripes
17

Подібно до коду Майкла-О, лише без необхідності посилання (пізнє зв’язування) і з меншим одним рядком.
* Я читав, що в 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
— Ель Скрипто
джерело
ScriptControl не працюватиме у 64-розрядних версіях Office, перевіряти рішення через htmlfileActiveX та обходити спосіб отримання ScriptControl для роботи з Excel x64 .
— omegastripes
13

З 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 як посилання, і все готово.

Так само, як і в останньому дописі, просто повна функція

— озмік
джерело
Готово. Добре, я не знав, що можу редагувати, і ви, на жаль, не отримуєте балів за редагування!
— ozmike
1
FYI Я намагався оновити інший пост, але мої редагування модеруються! напр. Майк переглянув це 18 годин тому: відхилити Ця редакція неправильна або спроба відповісти або прокоментувати існуючу публікацію. alex2410 переглянув це 18 годин тому: Відхилити Ця редакція неправильна або спроба відповісти або прокоментувати існуючу публікацію. bansi переглянув це 18 годин тому: відхилити Ця редакція неправильна або спроба відповісти або прокоментувати існуючу публікацію. -
— ozmike
ScriptControl не працюватиме у 64-розрядних версіях Office, перевіряти рішення через htmlfileActiveX та обходити спосіб отримання ScriptControl для роботи з Excel x64 .
— omegastripes
6

Ще одне рішення через 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

Оголошення htmlfileоб'єкта документа DOM статичною змінною дає єдину невелику затримку при першому виклику через init і робить цю функцію дуже швидкою для численних викликів, наприклад, для мене вона перетворює рядок із 100 символів довжиною 100000 разів за 2 секунди приблизно.

— омегастрипи
джерело
Голос за статичний. Це чудова ідея використовувати його з підпроцедурами та функціями, які викликаються кілька разів, щоб пришвидшити процес.
— Ryszard Jędraszyk
1
@ RyszardJędraszyk також Staticможна використовувати з ранньою прив'язкою для тих же цілей.
— omegastripes
4

(Наїзд на старій нитці). Лише для ударів, ось версія, яка використовує покажчики для складання рядка результату. Це приблизно в 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
— Джошуа Хоніг
джерело
2

Так само, як 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
— Флоран Б.
джерело
1

Код прийнятої відповіді зупинився на помилку Unicode в Access 2013, тому я написав для себе функцію з високою читабельністю, яка повинна відповідати RFC 3986 згідно з Девісом Пейшото , і спричинятиме мінімальні проблеми в різних середовищах.

Примітка: Спочатку слід замінити сам знак відсотка, інакше він подвійно закодує будь-які раніше закодовані символи. Додано заміну простору на +, щоб не відповідати RFC 3986, а забезпечити посилання, які не порушуються через форматування. Це необов’язково.

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
— Генрік Ерландссон
джерело
0

Якщо ви також хочете, щоб це працювало на 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
— Павло
джерело
0

У мене виникла проблема з кодуванням кириличних літер до 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

Удачі!

— ndd
джерело
0

Цей фрагмент, який я використав у своєму додатку для кодування 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
— Джиміт Рупані
джерело
0

Жодне з наведених тут рішень не працювало для мене нестандартно, але, швидше за все, це було пов’язано з відсутністю досвіду роботи з VBA. Це може бути ще й тому, що я просто скопіював і вставив деякі функції вище, не знаючи деталей, які, можливо, необхідні, щоб змусити їх працювати у середовищі VBA для додатків.

Моїми потребами було просто надіслати запити xmlhttp за допомогою URL-адрес, що містять деякі спеціальні символи норвезької мови. Деякі з наведених вище рішень кодують навіть двокрапки, що робило URL-адреси непридатними для того, що мені потрібно.

Потім я вирішив написати власну функцію URLEncode. Він не використовує більш розумне програмування, таке як від @ndd та @Tom. Я не дуже досвідчений програміст, але мені довелося зробити це раніше.

Я зрозумів, що проблема полягала в тому, що мій сервер не приймав кодування UTF-16, тому мені довелося написати функцію, яка перетворить UTF-16 на UTF-8. Хороше джерело інформації було знайдено тут і тут .

Я його широко не тестував, щоб перевірити, чи працює він з URL-адресою з символами, що мають вищі значення Unicode, і які видають більше 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
— francisaugusto
джерело
Використовуючи наш веб-сайт, ви визнаєте, що прочитали та зрозуміли наші Політику щодо файлів cookie та Політику конфіденційності.
Licensed under cc by-sa 3.0 with attribution required.