VB 6.0 - System.Uri.EscapeDataString in VB 6 - vb.net

Question

I recently made an app in VB 2010 and in order to make it independent of the .Net Framework, I begun remaking the app in VB 6.0. There's supposed to be a button on the form that, when pressed, opens the default email client. Then it opens a new email and copies into its body the text generated by the application on a Textbox. The problem with it is that the copied text in the body gets pasted with the wrong encoding and completely different from how it's supposed to be. I also encountered that problem in VB 2010 but I was able to fix this by using System.Uri.EscapeDataString like this
Process.Start("mailto:test#email.com?subject= &body=" & System.Uri.EscapeDataString(TextBox1.Text))
Is there a way to do something like this in vb 6.0 ?
ShellExecute Me.hwnd, "open", "mailto:test#email.com?subject= &body=" & NoonText.Text, _
vbNullString, vbNullString, 1
P.S I've tried URL Encoding it but wherever there are supposed to be spaces, crosses ("+") are pasted instead.

Answer 1

OK. Here's the bulk of the code that should behave like System.Uri.EscapeUriString and System.Uri.EscapeDataString using, respectively, the methods named EscapeURI() and EscapeURIData() provided in the listing below. Like any random piece of code, consider it's provided as is and thoroughly test it before you ever consider using it.
I'm providing the code for two (2) reasons:
Although your motives are questionable, as people with more reputation than me have rightly noted, there may arise a case where somebody will be confronted with the same question but for different reasons. The answer to your problem remains "Don't do it", but I still consider the technical question, per se, not any less valid and on topic.
Hopefully, with this answer you'll realize it's utterly pointless to reinvent the wheel. VB.NET was created as the successor of VB6, with among other objectives to provide means to build solutions for current, "real-world" problems all the while using less code, so it's more manageable and easier to maintain. Also, the VB6 runtime (MSVBVM60.DLL) as a dependency is more problematic than the .NET Framework simply because its support is no longer guaranteed.
So, here's the code. It's basically an implementation of character escaping as described in RFC 3986 on top of a UTF-8 encoding routine. The code is not optimized but commented so as to be easy to understand. Also, it does not support Internationalized Domain Names (RFC 3987).
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, src As Any, ByVal cb As Long)
Private Declare Function MultiByteToWideChar Lib "Kernel32.dll" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long _
) As Long
Private Declare Function WideCharToMultiByte Lib "Kernel32.dll" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long _
) As Long
Private Enum VbStrConv2
vbUpperCase = VbStrConv.vbUpperCase
vbLowerCase = VbStrConv.vbLowerCase
vbProperCase = VbStrConv.vbProperCase
vbWide = VbStrConv.vbWide
vbNarrow = VbStrConv.vbNarrow
vbHiragana = VbStrConv.vbHiragana
vbUnicode = VbStrConv.vbUnicode
vbFromUnicode = VbStrConv.vbFromUnicode
vbUTF8 = &H100&
vbFromUTF8 = &H200&
End Enum
Private Const CP_ACP As Long = 0 ' Default ANSI code page.
Private Const CP_UTF8 As Long = 65001 ' UTF8.
Private Const CP_UTF16_LE As Long = 1200 ' UTF16 - little endian.
Private Const CP_UTF16_BE As Long = 1201 ' UTF16 - big endian.
Private Const CP_UTF32_LE As Long = 12000 ' UTF32 - little endian.
Private Const CP_UTF32_BE As Long = 12001 ' UTF32 - big endian.
Public Function EscapeURI(ByVal URI As String, Optional ByVal JSCompatible As Boolean = False) As String
' As per "RFC 1738: Uniform Resource Locators (URL) specification"
' 21-06-2010: Modified to conform to "RFC 3986: Uniform Resource Identifier (URI): Generic Syntax"
Dim i As Long
Dim bAnsi() As Byte
Dim iAscii As Integer
Dim sEscapedUri As String
bAnsi = StrConv2(URI, VbStrConv2.vbUTF8)
sEscapedUri = vbNullString
For i = LBound(bAnsi) To UBound(bAnsi)
iAscii = bAnsi(i)
Select Case iAscii
' ASCII control caracters, always escape
Case 0 To 31, 127
If iAscii < 16 Then
sEscapedUri = sEscapedUri & "%0" & Hex$(iAscii)
Else
sEscapedUri = sEscapedUri & "%" & Hex$(iAscii)
End If
' Non-ASCII characters, always escape
Case 128 To 255
sEscapedUri = sEscapedUri & "%" & Hex$(iAscii)
' Reserved characters, don't escape with an URI
' RFC 3986 section 2.2 Reserved Characters (January 2005)
' ! # $ & ' ( ) * + , / : ; = ? # [ ]
Case 33, 35, 36, 38, 39, 40, 41, 42, 43, 44, 47, 58, 59, 61, 63, 64, 91, 93
If JSCompatible Then
Select Case iAscii
' [ ]
Case 91, 93
' ECMAScript's encodeURI() escapes those
' (since IPv6, hosts can be e.g. [::1/128] so we want to preserve them unescaped)
sEscapedUri = sEscapedUri & "%" & Hex$(iAscii)
Case Else
sEscapedUri = sEscapedUri & Chr$(iAscii)
End Select
Else
sEscapedUri = sEscapedUri & Chr$(iAscii)
End If
' Unreserved characters, never escape
' RFC 3986 section 2.3 Unreserved Characters (January 2005)
' - . 0 ... 9 A ... Z a .... z _ ~
Case 45, 46, 48 To 57, 65 To 90, 97 To 122, 95, 126
sEscapedUri = sEscapedUri & Chr$(iAscii)
' Unsafe characters, always escape
' " % < > \ ^ ` { | }
Case 34, 37, 60, 62, 92, 94, 96, 123, 124, 125
sEscapedUri = sEscapedUri & "%" & Hex$(iAscii)
' Space, escaped
Case 32
sEscapedUri = sEscapedUri & "%20"
Case Else
sEscapedUri = sEscapedUri & "%" & Hex$(iAscii)
End Select
Next i
EscapeURI = sEscapedUri
End Function
Public Function EscapeURIData(ByVal URIData As String, Optional ByVal JSCompatible As Boolean = False) As String
' As per "RFC 1738: Uniform Resource Locators (URL) specification"
' 21-06-2010: Modified to conform to "RFC 3986: Uniform Resource Identifier (URI): Generic Syntax"
Dim i As Long
Dim bAnsi() As Byte
Dim iAscii As Integer
Dim sEscapedData As String
bAnsi = StrConv2(URIData, VbStrConv2.vbUTF8)
sEscapedData = vbNullString
For i = LBound(bAnsi) To UBound(bAnsi)
iAscii = bAnsi(i)
Select Case iAscii
' ASCII control caracters, always escape
Case 0 To 31, 127
If iAscii < 16 Then
sEscapedData = sEscapedData & "%0" & Hex$(iAscii)
Else
sEscapedData = sEscapedData & "%" & Hex$(iAscii)
End If
' Non-ASCII characters, always escape
Case 128 To 255
sEscapedData = sEscapedData & "%" & Hex$(iAscii)
' Reserved characters, always escape when treated as data
' RFC 3986 section 2.2 Reserved Characters (January 2005)
' ! # $ & ' ( ) * + , / : ; = ? # [ ]
Case 33, 35, 36, 38, 39, 40, 41, 42, 43, 44, 47, 58, 59, 61, 63, 64, 91, 93
If JSCompatible Then
Select Case iAscii
' ! ' ( ) *
Case 33, 39, 40, 41, 42
' ECMAScript's encodeURIComponent() doesn't escape those
sEscapedData = sEscapedData & Chr$(iAscii)
Case Else
sEscapedData = sEscapedData & "%" & Hex$(iAscii)
End Select
Else
sEscapedData = sEscapedData & "%" & Hex$(iAscii)
End If
' Unreserved characters, never escape
' RFC 3986 section 2.3 Unreserved Characters (January 2005)
' - . 0 ... 9 A ... Z a .... z _ ~
Case 45, 46, 48 To 57, 65 To 90, 97 To 122, 95, 126
sEscapedData = sEscapedData & Chr$(iAscii)
' Unsafe characters, always escape
' " % < > \ ^ ` { | }
Case 34, 37, 60, 62, 92, 94, 96, 123, 124, 125
sEscapedData = sEscapedData & "%" & Hex$(iAscii)
' Space, escaped
Case 32
sEscapedData = sEscapedData & "%20"
Case Else
sEscapedData = sEscapedData & "%" & Hex$(iAscii)
End Select
Next i
EscapeURIData = sEscapedData
End Function
'
' Utilities
'
Private Function StrConv2(Expr As Variant, Conversion As VbStrConv2, Optional LocaleID As Long = 0)
Const METHOD_NAME = "StrConv2"
Dim sExpr As String, arr_bytInput() As Byte, lLBound As Long
Select Case Conversion
Case VbStrConv2.vbUTF8 ' LocaleID not used (no case changing, no code page mapping)
Dim lInputChars As Long
Dim lOutputBytes As Long, arr_bytOutputBytes() As Byte
' Expected input: Unicode (UCS-2)
Select Case VarType(Expr)
Case vbString
sExpr = CStr(Expr)
' Get length of input, in *characters*
lInputChars = Len(sExpr)
' Copy input string as-is
arr_bytInput = sExpr
Case (vbArray + vbByte)
' Get length of input, in *characters*
lInputChars = (UBound(Expr) - LBound(Expr) + 1) \ 2
' Copy array (same type)
arr_bytInput = Expr
Case Else
Err.Raise 13, METHOD_NAME, "Expr: Type mismatch (in " & METHOD_NAME & "())"
End Select
' Get size of output strings, in *bytes*
lOutputBytes = WideCharToMultiByte(CP_UTF8, 0, VarPtr(arr_bytInput(0)), lInputChars, 0, 0, 0, 0)
' Size appropriately
ReDim arr_bytOutputBytes(lOutputBytes - 1)
' Second call
lOutputBytes = WideCharToMultiByte(CP_UTF8, 0, VarPtr(arr_bytInput(0)), lInputChars, VarPtr(arr_bytOutputBytes(0)), lOutputBytes, 0, 0)
' Return as array of bytes
StrConv2 = arr_bytOutputBytes
Case VbStrConv2.vbFromUTF8 ' LocaleID not used (no case changing, no code page mapping)
Dim lInputBytes As Long
Dim lOutputChars As Long, arr_bytOutputChars() As Byte
' Expected input: UTF-8
Select Case VarType(Expr)
Case vbString
arr_bytInput = StrConv(Expr, vbFromUnicode)
' Get length of input, in *bytes*
lInputBytes = (UBound(arr_bytInput) - LBound(arr_bytInput) + 1)
Case (vbArray + vbByte)
' Copy array (same type)
arr_bytInput = Expr
' Get length of input, in *bytes*
lInputBytes = (UBound(arr_bytInput) - LBound(arr_bytInput) + 1)
Case Else
Err.Raise 13, METHOD_NAME, "Expr: Type mismatch (in " & METHOD_NAME & "())"
End Select
' Get size of output strings, in *chars*
lOutputChars = MultiByteToWideChar(CP_UTF8, 0, VarPtr(arr_bytInput(0)), lInputBytes, 0, 0)
' Size appropriately
ReDim arr_bytOutputChars(lOutputChars * 2 - 1)
' Second call
lOutputChars = MultiByteToWideChar(CP_UTF8, 0, VarPtr(arr_bytInput(0)), lInputBytes, VarPtr(arr_bytOutputChars(0)), lOutputChars)
' Return as string
sExpr = arr_bytOutputChars
StrConv2 = Left$(sExpr, lOutputChars)
Case Else
StrConv2 = StrConv(Expr, Conversion, LocaleID)
End Select
End Function