未分类

vb6实现URL编码和解码(支持UTF8)

把下面的代码复制到一个新建的 ToolsHttp.bas 文件, 然后使用:

sResult = ToolsHttp.UrlDecodeUtf8(sUrl)

以下代码改编自csdn, 转载注意包含原文链接

(也包含了一些我自己用的函数)

Option Explicit

Public Const C_CONTENT_TYPE_FORM_URLENCODED As String = "application/x-www-form-urlencoded"
Public Const C_CONTENT_TYPE_JSON As String = "application/json"
Public Const C_CONTENT_TYPE_STREAM As String = "application/octet-stream"
Public Const C_HEADER_FIELD_CONTENT_TYPE As String = "Content-Type"



'————————————————VB URL的编解码源码 GB2312 UTF-8编解码
'
'                            版权声明:本文为博主原创文章,遵循 CC 4.0 BY-SA 版权协议,转载请附上原文出处链接和本声明。
'
'原文链接:https://blog.csdn.net/gs1069405343/article/details/50471825

Public Function UrlDecodeUtf8(ByVal Url As String) As String
    Dim b, ub                                                                   ''中文字的Unicode码(2字节)
    Dim aa, BB
    Dim UtfB                                                                    ''Utf-8单个字节
    Dim UtfB1, UtfB2, UtfB3                                                     ''Utf-8码的三个字节
    Dim i, n, s
    Dim str1 As String
    Dim str2 As String
    n = 0
    ub = 0
    For i = 1 To Len(Url)
        b = Mid(Url, i, 1)
        Select Case b
        Case "+"
            s = s & " "
        Case "%"
            ub = Mid(Url, i + 1, 2)
            If InStr(ub, vbLf) <= 0 And ub <> "" Then
                aa = Mid(ub, 1, 1)
                BB = Mid(ub, 2, 1)
                If aa < "g" And aa < "G" And BB < "g" And BB < "G" And aa <> "%" And BB <> "%" Then
                    UtfB = CInt("&H" & ub)
                End If
            End If
            
            If UtfB < 128 Then
                i = i + 2
                s = s & ChrW(UtfB)
            Else
                UtfB1 = (UtfB And &HF) * &H1000                                 ''取第1个Utf-8字节的二进制后4位
                str1 = Mid(Url, i + 4, 2)
                If InStr(str1, vbLf) <= 0 And str1 <> "" Then
                    
                    aa = Mid(str1, 1, 1)
                    BB = Mid(str1, 2, 1)
                    If aa < "g" And aa < "G" And BB < "g" And BB < "G" And aa <> "%" And BB <> "%" Then
                        UtfB2 = (CInt("&H" & str1) And &H3F) * &H40             ''取第2个Utf-8字节的二进制后6位
                    End If
                    
                    str2 = Mid(Url, i + 7, 2)
                    If InStr(str2, vbLf) <= 0 And str2 <> "" Then
                        aa = Mid(str2, 1, 1)
                        BB = Mid(str2, 2, 1)
                        If aa < "g" And aa < "G" And BB < "g" And BB < "G" And aa <> "%" And BB <> "%" Then
                            UtfB3 = CInt("&H" & str2) And &H3F                  ''取第3个Utf-8字节的二进制后6位
                        End If
                    End If
                End If
                s = s & ChrW(UtfB1 Or UtfB2 Or UtfB3)
                i = i + 8
            End If
            
        Case Else                                                               ''Ascii码
            s = s & b
        End Select
    Next
    UrlDecodeUtf8 = s
End Function
'UTF-8编码
Public Function UrlEncodUtf8(ByVal szInput) As String
    Dim wch, uch, szRet
    Dim x
    Dim nAsc, nAsc2, nAsc3
    If szInput = "" Then
        UrlEncodUtf8 = szInput
        Exit Function
    End If
    For x = 1 To Len(szInput)
        wch = Mid(szInput, x, 1)
        nAsc = AscW(wch)
        
        If nAsc < 0 Then nAsc = nAsc + 65536
        
        If (nAsc And &HFF80) = 0 Then
            szRet = szRet & wch
        Else
            If (nAsc And &HF000) = 0 Then
                uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
                szRet = szRet & uch
            Else
                uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
                Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
                Hex(nAsc And &H3F Or &H80)
                szRet = szRet & uch
            End If
        End If
    Next
    UrlEncodUtf8 = szRet
End Function


'GB2312 URL解码
Public Function UrlDecode(ByVal Url As String) As String
    Dim i As Long, C As String, d As Long, GB_UrlDecode As String
    i = 1
    While i <= Len(Url)
        C = Mid$(Url, i, 1)
        i = i + 1
        If C = "%" Then
            d = Val("&H" & Mid$(Url, i, 2))
            If d >= 128 Then
                d = d * 256 + Val("&H" & Mid$(Url, i + 3, 2))
                i = i + 5
            Else
                i = i + 2
            End If
            GB_UrlDecode = GB_UrlDecode + Chr$(d)
        Else
            GB_UrlDecode = GB_UrlDecode + C
        End If
    Wend
    UrlDecode = GB_UrlDecode
End Function
'GB2312 URL编码
Public Function UrlEncode(ByRef strURL As String) As String
    Dim i, GB_URLEncode As String
    Dim tempStr
    For i = 1 To Len(strURL)
        If InStr("-,.0123456789/", Mid(strURL, i, 1)) Then
            GB_URLEncode = GB_URLEncode & Mid(strURL, i, 1)
        Else
            If Asc(Mid(strURL, i, 1)) < 0 Then
                tempStr = "%" & Right(CStr(Hex(Asc(Mid(strURL, i, 1)))), 2)
                tempStr = "%" & Left(CStr(Hex(Asc(Mid(strURL, i, 1)))), Len(CStr(Hex(Asc(Mid(strURL, i, 1))))) - 2) & tempStr
                GB_URLEncode = GB_URLEncode & tempStr
            ElseIf (Asc(Mid(strURL, i, 1)) >= 65 And Asc(Mid(strURL, i, 1)) <= 90) Or (Asc(Mid(strURL, i, 1)) >= 97 And Asc(Mid(strURL, i, 1)) <= 122) Then
                GB_URLEncode = GB_URLEncode & Mid(strURL, i, 1)
            Else
                GB_URLEncode = GB_URLEncode & "%" & Hex(Asc(Mid(strURL, i, 1)))
            End If
        End If
    Next
    UrlEncode = GB_URLEncode
End Function


'————————————————VB URL的编解码源码 GB2312 UTF-8编解码
'
'                            版权声明:本文为博主原创文章,遵循 CC 4.0 BY-SA 版权协议,转载请附上原文出处链接和本声明。
'
'原文链接:https://blog.csdn.net/gs1069405343/article/details/50471825


Sub Test()
    ' Usage
    Dim sUrl As String
    Dim sResult As String
    
    sUrl = "POST /a/%E6%B5%8B%E8%AF%95%20%E7%9A%84%E9%82%93%E4%BC%9F/c?d=123&e=%E5%9B%9B%E7%89%A9"
    sResult = UrlDecodeUtf8(sUrl)
    Debug.Print sResult
End Sub



Rem 解析Request内容,即原始键值对
Public Function ParseContent(Content As String, Obj As Scripting.Dictionary) As Boolean
    Rem 需要增加对数组类型的处理
    Dim a, b, k, v, x: a = Split(Content, "&")
    If UBound(a) > -1 Then
        For x = 0 To UBound(a)
            b = Split(a(x) & "==", "=")
            k = Trim(b(0))
            v = Trim(b(1))
            If k <> "" Then
                Obj.Add k, v
            End If
        Next
    End If
End Function
Rem 解析Request.Header内容,即标头键值对
Public Function ParseKeyValue(Content As String, Obj As Scripting.Dictionary) As Boolean
    Rem 需要增加对数组类型的处理
    Dim a, b, k, v, x: a = Split(Content, vbCrLf)
    If UBound(a) > -1 Then
        For x = 0 To UBound(a)
            b = Split(a(x) & "::", ":")
            k = Trim(b(0))
            v = Trim(b(1))
            '            If k <> "" Then
            Obj.Add k, v
            '        End If
        Next
    End If
End Function

Public Function MapMethod(Name As String) As Long
    Dim Arr: Arr = Array("ANY", "POST", "GET", "PUT", "DELETE", "OPTION")
    MapMethod = ToolsArray.GetIndexByValue(Arr, Name)
End Function
Public Function MapMethodName(Index As Long) As String
    Dim Arr: Arr = Array("ANY", "POST", "GET", "PUT", "DELETE", "OPTION")
    MapMethodName = Arr(Index)
End Function


Views: 18

Hi, I’m 邓伟

本来无一物,何处惹尘埃

发表回复