[英]How can I URL encode a string in Excel VBA?
是否有内置的方法可以在 Excel VBA 中对字符串进行 URL 编码,还是我需要手动滚动此功能?
不,没有内置(直到 Excel 2013 -请参阅此答案)。
这个答案中有三个版本的URLEncode()
。
支持 UTF-8 编码并基于ADODB.Stream
的变体(包括对项目中“Microsoft ActiveX 数据对象”库的最新版本的引用):
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 开始,现在有一种使用工作表函数ENCODEURL
对 URL 进行编码的内置方法。
要在您的 VBA 代码中使用它,您只需要调用
EncodedUrl = WorksheetFunction.EncodeUrl(InputString)
以上支持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
享受!
虽然,这个已经很老了。 我想出了一个基于这个答案的解决方案:
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 作为参考,您就完成了。
与上一篇文章相同,只是完整的功能..有效!
通过htmlfile
ActiveX 的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 文档对象声明为静态变量会在第一次调用时由于 init 产生唯一的小延迟,并使该函数对于多次调用非常快,例如对我来说,它在大约 2 秒内将 100 个字符长度的字符串转换 100000 次。
(撞到旧线程)。 只是为了踢球,这里有一个使用指针来组装结果字符串的版本。 它大约是已接受答案中更快的第二个版本的 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
接受的答案的代码因 Access 2013 中的 Unicode 错误而停止,因此我为自己编写了一个具有高可读性的函数,该函数应遵循Davis Peixoto 的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
如果您还希望它在 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 上工作可能需要的细节。
我的需要只是使用包含挪威语言的一些特殊字符的 url 发送 xmlhttp 请求。 上面的一些解决方案甚至对冒号进行编码,这使得 url 不适合我所需要的。
然后我决定编写自己的 URLEncode 函数。 它没有使用更聪明的编程,例如来自@ndd 和@Tom 的编程。 我不是一个非常有经验的程序员,但我必须尽快完成这项工作。
我意识到问题是我的服务器不接受 UTF-16 编码,所以我必须编写一个函数来将 UTF-16 转换为 UTF-8。 在这里和这里找到了一个很好的信息来源。
我还没有对它进行广泛的测试,以检查它是否适用于具有更高 unicode 值的字符的 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/docs/#/WebHelpers/UrlEncode
它似乎与 JavaScript 中的encodeURIComponent()
类似。
txt = IIf(text = "", " ", utf16to8(text)): l = Len(txt)在此输入图片描述
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.