为了账号安全,请及时绑定邮箱和手机立即绑定

请问如何在ExcelVBA中对字符串进行URL编码?

/ 猿问

请问如何在ExcelVBA中对字符串进行URL编码?

一只甜甜圈 2019-10-22 17:12:15

如何在ExcelVBA中对字符串进行URL编码?

是否有内置方式在ExcelVBA中对字符串进行URL编码,还是需要提交此功能?


查看完整描述

3 回答

?
芜湖不芜

不,没有内置的(直到Excel 2013-见这个答案).

有三个版本URLEncode()在这个答案里。

  • 有UTF-8支持的功能。

    你应该用这个

    (或

    替代实施

    为了与现代的要求兼容。
  • 为供参考和教育之用,在没有UTF-8支助的情况下,有两个职能:
    • 其中一个发现在第三方网站上,包括原样。(这是答案的第一个版本)
    • 一个优化的版本,我写的

支持UTF-8编码的变体,基于ADODB.Stream(在项目中包含对“MicrosoftActiveX数据对象”库的最新版本的引用):

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 IfEnd 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 = TempAnsEnd 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 IfEnd Function

请注意,这两个函数都不支持UTF-8编码。



查看完整回答
反对 回复 2019-10-23
?
若吾皇

为了更新这一点,自Excel 2013以来,现在有了一种使用工作表函数对URL进行编码的内置方式。ENCODEURL.

要在VBA代码中使用它,只需调用

EncodedUrl = WorksheetFunction.EncodeUrl(InputString)

文献资料


查看完整回答
反对 回复 2019-10-23
?
喵喔喔

上述支持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 LongPublic Function UTF16To8(ByVal UTF16 As String) 
    As StringDim sBuffer As StringDim lLength As LongIf 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 IfEnd FunctionPublic Function URLEncode( _
   StringVal As String, _   Optional SpaceAsPlus As Boolean = False, _   Optional UTF8Encode As Boolean = True _) 
   As StringDim 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

好好享受吧!



查看完整回答
反对 回复 2019-10-23

添加回答

回复

举报

0/150
提交
取消
意见反馈 帮助中心 APP下载
官方微信