Some time ago I was asked to help in decoding an URI Encoded string from VB6. URL Decoding is simple enough, but when you're working with Greek, Hebrew, etc. that just isn't enough.
A quick search revealed a truckload of samples on how to do URL Decoding, but URI Decoding is a bit harder. I decided to stand on the shoulders of geniuses and ran Reflector on the Microsoft.JScript.dll. The code was fairly easy to convert, but I thought I'd share it in case you don't want to do it yourself. :)
I've commented out (but otherwise left intact) all the spots where .NET would throw an exception, since this would be a good spot to implement your own error handler.
Anyway, bring on the code!
/ Johan
Private Function Encode2(ByVal Text1 As String) As String Dim builder1 As String builder1 = "" Dim num1 As Integer num1 = 0 Do While (num1 < Len(Text1)) Dim ch1 As String ch1 = Mid(Text1, num1 + 1, 1) If InURISet(ch1, 2) Then builder1 = builder1 & (ch1) Else Dim num2 As Integer num2 = AscW(ch1) If ((num2 >= 0) And (num2 <= 127)) Then Call AppendInHex(builder1, num2) ElseIf ((num2 >= 128) And (num2 <= 2047)) Then Call AppendInHex(builder1, (RShiftWord(num2, 6) Or 192)) Call AppendInHex(builder1, ((num2 And 63) Or 128)) ElseIf ((num2 < 55296) Or (num2 > 57343)) Then Call AppendInHex(builder1, (RShiftWord(num2, 12) Or 224)) Call AppendInHex(builder1, ((RShiftWord(num2, 6) And 63) Or 128)) Call AppendInHex(builder1, ((num2 And 63) Or 128)) Else If ((num2 >= 56320) And (num2 <= 57343)) Then' Throw New JScriptException(JSError.URIEncodeError) End If If (num1 >= Len(Text1)) Then' Throw New JScriptException(JSError.URIEncodeError) End If Dim num3 As Integer num3 = Mid(Text1, num1 + 1, 1) If ((num3 < 56320) Or (num3 > 57343)) Then' Throw New JScriptException(JSError.URIEncodeError) End If num2 = ((LShiftWord((num2 - 55296), 10) + num3) + 9216) Call AppendInHex(builder1, (RShiftWord(num2, 18) Or 240)) Call AppendInHex(builder1, ((RShiftWord(num2, 12) And 63) Or 128)) Call AppendInHex(builder1, ((RShiftWord(num2, 6) And 63) Or 128)) Call AppendInHex(builder1, ((num2 And 63) Or 128)) End If End If num1 = num1 + 1 Loop Encode2 = builder1End Function
Private Function Decode2(ByVal Text1 As String) As String Dim builder1 As String Dim num1 As Integer num1 = 0 Do While (num1 < Len(Text1)) Dim ch1 As String ch1 = Mid(Text1, (num1) + 1, 1) If (ch1 <> "%") Then builder1 = builder1 & (ch1) Else Dim ch2 As String Dim num2 As Integer num2 = num1 If ((num1 + 2) >= Len(Text1)) Then' Throw New JScriptException(JSError.URIDecodeError) End If Dim num3 As Byte num3 = HexValue(Mid(Text1, (num1 + 2), 1), Mid(Text1, (num1 + 3), 1)) num1 = (num1 + 2) If ((num3 And 128) = 0) Then ch2 = Chr(num3) Else Dim num4 As Integer num4 = 1 Do While ((LShiftWord(num3, (num4 And 31)) And 128) <> 0) num4 = num4 + 1 Loop If (((num4 = 1) Or (num4 > 4)) Or ((num1 + ((num4 - 1) * 3)) >= Len(Text1))) Then' Throw New JScriptException(JSError.URIDecodeError) End If Dim num5 As Integer num5 = (num3 And RShiftWord(255, ((num4 + 1) And 31))) Do While (num4 > 1) If (Mid(Text1, (num1 + 2), 1) <> "%") Then' Throw New JScriptException(JSError.URIDecodeError) End If num3 = HexValue(Mid(Text1, (num1 + 3), 1), Mid(Text1, (num1 + 4), 1)) num1 = (num1 + 3) If ((num3 And 192) <> 128) Then' Throw New JScriptException(JSError.URIDecodeError) End If num5 = ((LShiftWord(num5, 6)) Or (num3 And 63)) num4 = num4 - 1 Loop If ((num5 >= 55296) And (num5 < 57344)) Then' Throw New JScriptException(JSError.URIDecodeError) End If If (num5 < 65536) Then ch2 = (ChrW(num5)) Else If (num5 > 1114111) Then' Throw New JScriptException(JSError.URIDecodeError) End If builder1 = builder1 & (Chr(((RShiftWord((num5 - 65536), 10) And 1023) + 55296))) builder1 = builder1 & (Chr((((num5 - 65536) And 1023) + 56320))) GoTo Label_01D4 End If End If If InURISet(ch2, 0) Then ' This can probably be omitted. It looks like it'll never be True. builder1 = builder1 & Mid(Text1, num2 + 1, ((num1 - num2) + 1)) Else builder1 = builder1 & ch2 End IfLabel_01D4: End If num1 = num1 + 1 Loop Decode2 = builder1End Function
Private Function HexValue(ByVal ch1 As String, ByVal ch2 As String) As Byte Dim num1 As Integer Dim num2 As Integer num1 = HexDigit(ch1) num2 = HexDigit(ch2) If ((num1 < 0) Or (num2 < 0)) Then' Throw New JScriptException(JSError.URIDecodeError) End If HexValue = CByte((LShiftWord(num1, 4) Or num2))End Function
Private Function HexDigit(ByVal c As String) As Integer Dim retVal As Integer retVal = -1 If ((c >= "0") And (c <= "9")) Then retVal = (Asc(c) - Asc("0")) End If If ((c >= "A") And (c <= "F")) Then retVal = (((10) + Asc(c)) - Asc("A")) End If If ((c >= "a") And (c <= "f")) Then retVal = (((10) + Asc(c)) - Asc("a")) End If HexDigit = retValEnd Function
Function LShiftWord(ByVal w As Integer, ByVal c As Integer) As Integer LShiftWord = w * (2 ^ c)End Function
Function RShiftWord(w As Integer, c As Integer) As Integer RShiftWord = w \ (2 ^ c)End Function
Private Function InURISet(ByVal ch As String, ByVal flags As Integer) As Boolean Dim bRetval As Boolean bRetval = False If (flags = 2) Then If ((((ch >= "0") And (ch <= "9")) Or ((ch >= "A") And (ch <= "Z"))) Or ((ch >= "a") And (ch <= "z"))) Then bRetval = True End If Select Case ch Case "_", "~", "'", "(", ")", "*", "-", ".", "!" bRetval = True End Select End If If (flags = 1) Then Select Case ch Case "#", "$", "&", "+", ",", "/", ":", ";", "=", "?", "@" bRetval = True End Select End If InURISet = bRetvalEnd Function
Private Sub AppendInHex(ByRef bs As String, ByVal value As Integer) bs = bs & "%" Dim num1 As Integer num1 = (RShiftWord(value, 4) And 15) bs = bs & (IIf((num1 >= 10), Chr((num1 - 10) + 65), Chr(num1 + 48))) num1 = (value And 15) bs = bs & (IIf((num1 >= 10), Chr((num1 - 10) + 65), Chr(num1 + 48)))End Sub