VBA UrlDecode和VBA UrlEncode
这是两个非常用的VBA脚本函数，哈哈……
是从百度上辛苦找到的，现在收藏下
UrlDecode函数：
1 Function URLDecode(ByVal What)
2 'URL decode Function
3 '2001 Antonin Foller, PSTRUH Software, http://www.motobit.com
4 Dim Pos, pPos
5
6 'replace + To Space
7 What = Replace(What, "+", " ")
8
9 on error resume Next
10 Dim Stream: Set Stream = CreateObject("ADODB.Stream")
11 If err = 0 Then 'URLDecode using ADODB.Stream, If possible
12 on error goto 0
13 Stream.Type = 2 'String
14 Stream.Open
15
16 'replace all %XX To character
17 Pos = InStr(1, What, "%")
18 pPos = 1
19 Do While Pos > 0
20 Stream.WriteText Mid(What, pPos, Pos - pPos) + _
21 Chr(CLng("&H" & Mid(What, Pos + 1, 2)))
22 pPos = Pos + 3
23 Pos = InStr(pPos, What, "%")
24 Loop
25 Stream.WriteText Mid(What, pPos)
26
27 'Read the text stream
28 Stream.Position = 0
29 URLDecode = Stream.ReadText
30
31 'Free resources
32 Stream.Close
33 Else 'URL decode using string concentation
34 on error goto 0
35 'UfUf, this is a little slow method.
36 'Do Not use it For data length over 100k
37 Pos = InStr(1, What, "%")
38 Do While Pos>0
39 What = Left(What, Pos-1) + _
40 Chr(Clng("&H" & Mid(What, Pos+1, 2))) + _
41 Mid(What, Pos+3)
42 Pos = InStr(Pos+1, What, "%")
43 Loop
44 URLDecode = What
45 End If
46 End Function
UrlEncode函数
View Code
1 Public Function UrlEncode(ByRef szString As String) As String
2 Dim szChar As String
3 Dim szTemp As String
4 Dim szCode As String
5 Dim szHex As String
6 Dim szBin As String
7 Dim iCount1 As Integer
8 Dim iCount2 As Integer
9 Dim iStrLen1 As Integer
10 Dim iStrLen2 As Integer
11 Dim lResult As Long
12 Dim lAscVal As Long
13 szString = Trim$(szString)
14 iStrLen1 = Len(szString)
15 For iCount1 = 1 To iStrLen1
16 szChar = Mid$(szString, iCount1, 1)
17 lAscVal = AscW(szChar)
18 If lAscVal >= &H0 And lAscVal <= &HFF Then
19 If (lAscVal >= &H30 And lAscVal <= &H39) Or _
20 (lAscVal >= &H41 And lAscVal <= &H5A) Or _
21 (lAscVal >= &H61 And lAscVal <= &H7A) Then
22 szCode = szCode & szChar
23 Else
24 szCode = szCode & "%" & Hex(AscW(szChar))
25 End If
26 Else
27 szHex = Hex(AscW(szChar))
28 iStrLen2 = Len(szHex)
29 For iCount2 = 1 To iStrLen2
30 szChar = Mid$(szHex, iCount2, 1)
31 Select Case szChar
32 Case Is = "0"
33 szBin = szBin & "0000"
34 Case Is = "1"
35 szBin = szBin & "0001"
36 Case Is = "2"
37 szBin = szBin & "0010"
38 Case Is = "3"
39 szBin = szBin & "0011"
40 Case Is = "4"
41 szBin = szBin & "0100"
42 Case Is = "5"
43 szBin = szBin & "0101"
44 Case Is = "6"
45 szBin = szBin & "0110"
46 Case Is = "7"
47 szBin = szBin & "0111"
48 Case Is = "8"
49 szBin = szBin & "1000"
50 Case Is = "9"
51 szBin = szBin & "1001"
52 Case Is = "A"
53 szBin = szBin & "1010"
54 Case Is = "B"
55 szBin = szBin & "1011"
56 Case Is = "C"
57 szBin = szBin & "1100"
58 Case Is = "D"
59 szBin = szBin & "1101"
60 Case Is = "E"
61 szBin = szBin & "1110"
62 Case Is = "F"
63 szBin = szBin & "1111"
64 Case Else
65 End Select
66 Next iCount2
67 szTemp = "1110" & Left$(szBin, 4) & "10" & Mid$(szBin, 5, 6) & "10" & Right$(szBin, 6)
68 For iCount2 = 1 To 24
69 If Mid$(szTemp, iCount2, 1) = "1" Then
70 lResult = lResult + 1 * 2 ^ (24 - iCount2)
71 Else: lResult = lResult + 0 * 2 ^ (24 - iCount2)
72 End If
73 Next iCount2
74 szTemp = Hex(lResult)
75 szCode = szCode & "%" & Left$(szTemp, 2) & "%" & Mid$(szTemp, 3, 2) & "%" & Right$(szTemp, 2)
76 End If
77 szBin = vbNullString
78 lResult = 0
79 Next iCount1
80 UrlEncode = szCodeEnd Function
