كيف يمكنني ترميز URL لسلسلة في Excel VBA؟

StackOverflow https://stackoverflow.com/questions/218181

سؤال

هل هناك طريقة مضمنة لترميز عنوان URL لسلسلة في Excel VBA أو هل أحتاج إلى تسليم هذه الوظيفة؟

هل كانت مفيدة؟

المحلول

لا، لا شيء مدمج (حتى اكسل 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.

نصائح أخرى

لمن أجل تحقيق هذا الأمر حتى الآن، منذ اكسل 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")

واضافة مايكروسوفت التحكم Script كمرجع وانت القيام به.

ومجرد ملاحظة جانبية، لأن الجزء JS، وهذا هو تماما UTF-8-متوافق. VB سيتم تحويل بشكل صحيح من UTF-16 إلى UTF-8.

وعلى غرار كود مايكل-O، وفقط من دون الحاجة إلى الرجوع (أواخر ربط) وأقل سطر واحد.
* قرأت، وذلك في اكسل 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

ومنذ مكتب 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

واضافة مايكروسوفت التحكم Script كمرجع وانت القيام به.

ونفس آخر مشاركة فقط ..works وظيفة كاملة!

وحل واحد أكثر عبر htmlfile اكتف: 

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 كائن المستند كما متغير ثابت يعطي تأخير صغيرة فقط عندما دعا أول مرة بسبب الحرف الأول، ويجعل هذه الوظيفة سريع جدا للعديد من المكالمات، والبريد. ز. بالنسبة لي بتحويل سلسلة من طول 100 حرف 100000 مرات في 2 ثانية تقريبا ..

و(نتوء على موضوع القديم). فقط لركلات، وهنا الإصدار الذي يستخدم مؤشرات لتجميع سلسلة النتيجة. ولكن عن 2X - 4x رقمي بأسرع النسخة أسرع الثاني في إجابة مقبولة 

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

إذا كنت تريد أيضا أن تعمل على ماك إنشاء وظيفة منفصلة 

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.

وI تعديل أحد البرامج النصية أعلاه لمطابقة السيريلية خريطة شار. Implmented هو القسم cyrrilic من

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 استخدام عناوين المواقع التي تحتوي على بعض الأحرف الخاصة باللغة النرويجية. بعض من الحلول المذكورة أعلاه ترميز حتى كولون، الأمر الذي جعل عناوين المواقع غير صالحة للما احتاجه.

وبعد ذلك قررت أن أكتب لي وظيفة URLEncode الخاصة. لا يستخدم البرمجة أكثر ذكاء مثل واحد منndd وTom. أنا لست مبرمج خبرة كبيرة، ولكن كان لزاما على هذا القيام به عاجلا.

وأدركت أن المشكلة هي أن خدمة بلدي لم يقبل UTF-16 ترميزات، لذلك اضطررت لكتابة وظيفة التي من شأنها تحويل UTF-16 إلى UTF-8. تم العثور على مصدر جيد من المعلومات هنا و هنا .

وأنا لم تختبر على نطاق واسع لمعرفة ما اذا كان يعمل مع رابط مع شخصيات التي تحتوي على قيم يونيكود العليا والتي من شأنها أن تنتج أكثر من 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 الأدوات لديه وظيفة لذلك:

http://vba-tools.github.io / VBA ويب / مستندات / # / WebHelpers / UrlEncode

ويبدو للعمل مماثلة لencodeURIComponent() في جافا سكريبت.

مرخصة بموجب: CC-BY-SA مع الإسناد
لا تنتمي إلى StackOverflow
scroll top