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