Access2Base - UTF-8 encoding and %-encoding

Application to SendMailWithoutAttachment => "mailto: ... " uri

Change-Id: I53aa0325c048dca678ff134908d448afab08933d

2 files changed, 108 insertions, 10 deletions

diff --git a/wizards/source/access2base/DoCmd.xba b/wizards/source/access2base/DoCmd.xba
index ce20dac48ce3..28e2bc38b944 100644
--- a/wizards/source/access2base/DoCmd.xba
+++ b/wizards/source/access2base/DoCmd.xba
@@ -2420,29 +2420,23 @@ Private Function _SendWithoutAttachment(ByVal pvTo As Variant _
 						, ByVal psBody As String _
 						) As Boolean
 'Send simple message with mailto: syntax
-Dim sMailTo As String, sTo As String, sCc As String, sBcc As String, sSubject As String, sBody As String, oDispatch As Object
+Dim sMailTo As String, sTo As String, sCc As String, sBcc As String, oDispatch As Object
 Const cstComma = ","
-Const cstSpace = "%20"
-Const cstLF = "%0A"
 
 	If _ErrorHandler() Then On Local Error Goto Error_Function
 
 	If UBound(pvTo) >= 0	Then sTo = Trim(Join(pvTo, cstComma))	Else sTo = ""
 	If UBound(pvCc) >= 0	Then sCc = Trim(Join(pvCc, cstComma))	Else sCc = ""
 	If UBound(pvBcc) >= 0	Then sBcc = Trim(Join(pvBcc, cstComma))	Else sBcc = ""
-	If psSubject <> ""		Then sSubject = Join(Split(psSubject, " "), cstSpace)	Else sSubject = ""
-	If psBody <> ""	Then
-		sBody = Join(Split(Join(Split(psBody, Chr(13)), ""), Chr(10), cstLF)
-		sBody = Join(Split(sBody, " "), cstSpace)
-	End If
 	
 	sMailTo = "mailto:" _
 				& sTo & "?" _
 				& Iif(sCc = "", "", "cc=" & sCc & "&") _
 				& Iif(sBcc = "", "", "bcc=" & sBcc & "&") _
-				& Iif(sSubject = "", "", "subject=" & sSubject & "&") _
-				& Iif(sBody = "", "", "body=" & sBody & "&")
+				& Iif(psSubject = "", "", "subject=" & psSubject & "&") _
+				& Iif(psBody = "", "", "body=" & psBody & "&")
 	If Right(sMailTo, 1) = "&" Or Right(sMailTo, 1) = "?" Then sMailTo = Left(sMailTo, Len(sMailTo) - 1)
+	sMailTo = Utils._URLEncode(sMailTo)
 	
 	oDispatch = createUnoService( "com.sun.star.frame.DispatchHelper")
 	oDispatch.executeDispatch(StarDesktop, sMailTo, "", 0, Array())
diff --git a/wizards/source/access2base/Utils.xba b/wizards/source/access2base/Utils.xba
index 256ff853231b..321db78bac67 100644
--- a/wizards/source/access2base/Utils.xba
+++ b/wizards/source/access2base/Utils.xba
@@ -586,6 +586,42 @@ Dim vSubStrings() As Variant, i As Integer, iLen As Integer
 End Function	'	PCase		V0.9.0
 
 REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _PercentEncode(ByVal psChar As String) As String
+'	Percent encoding of single psChar character
+'	https://en.wikipedia.org/wiki/UTF-8
+
+Dim lChar As Long, sByte1 As String, sByte2 As String, sByte3 As String
+	lChar = Asc(psChar)
+	
+	Select Case lChar
+		Case 48 To 57, 65 To 90, 97 To 122		'	0-9, A-Z, a-z
+			_PercentEncode = psChar
+		Case "-", ".", "_", "~"
+			_PercentEncode = psChar
+		Case "!", "$", "&", "'", "(", ")", "*", "+", ",", ";", "="		'	Reserved characters used as delimitors in query strings
+			_PercentEncode = psChar
+		Case " ", "%"
+			_PercentEncode = "%" & Right("00" & Hex(lChar), 2)
+		Case 0 To 127
+			_PercentEncode = psChar
+		Case 128 To 2047
+			sByte1 = "%" & Right("00" & Hex(Int(lChar / 64) + 192), 2)
+			sByte2 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2)
+			_PercentEncode = sByte1 & sByte2
+		Case 2048 To 65535
+			sByte1 = "%" & Right("00" & Hex(Int(lChar / 4096) + 224), 2)
+			sByte2 = "%" & Right("00" & Hex(Int(lChar - (4096 * Int(lChar / 4096))) /64 + 128), 2)
+			sByte3 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2)
+			_PercentEncode = sByte1 & sByte2 & sByte3
+		Case Else				'	Not supported
+			_PercentEncode = psChar
+	End Select
+	
+	Exit Function
+
+End Function	'	_PercentEncode V1.4.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
 Public Sub _ResetCalledSub(ByVal psSub As String)
 '	Called in bottom of each public function. _A2B_.CalledSub variable is used for error handling
 '	Used to trace routine in/outs and to clarify error messages
@@ -690,4 +726,72 @@ Dim sTrim As String, vTrim() As Variant, i As Integer, j As Integer, iCount As I
 	_TrimArray() = vTrim()
 
 End Function	'	TrimArray	V0.9.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _URLEncode(ByVal psToEncode As String) As String
+'	http://www.w3schools.com/tags/ref_urlencode.asp
+'	http://xkr.us/articles/javascript/encode-compare/
+'	http://tools.ietf.org/html/rfc3986
+
+Dim sEncoded As String, sChar As String
+Dim lCurrentChar As Long, bQuestionMark As Boolean
+
+	sEncoded = ""
+	bQuestionMark = False
+	For lCurrentChar = 1 To Len(psToEncode)
+		sChar = Mid(psToEncode, lCurrentChar, 1)
+		Select Case sChar
+			Case " ", "%"
+				sEncoded = sEncoded & _PercentEncode(sChar)
+			Case "?"					'	Is it the first "?" ?
+				If bQuestionMark Then			'	"?" introduces in a URL the arguments part
+					sEncoded = sEncoded & _PercentEncode(sChar)
+				Else
+					sEncoded = sEncoded & sChar
+					bQuestionMark = True
+				End If
+			Case "\"
+				If bQuestionMark Then
+					sEncoded = sEncoded & _PercentEncode(sChar)
+				Else
+					sEncoded = sEncoded & "/"	'	If Windows file naming ...
+				End If
+			Case Else
+				If bQuestionMark Then
+					sEncoded = sEncoded & _PercentEncode(sChar)
+				Else
+					sEncoded = sEncoded & _UTF8Encode(sChar)	'	Because IE does not support %encoding in first part of URL
+				End If
+		End Select
+	Next lCurrentChar
+ 
+	_URLEncode = sEncoded
+
+End Function	'	_URLEncode V1.4.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _UTF8Encode(ByVal psChar As String) As String
+'	&-encoding of single psChar character (e.g. "é" becomes "é" or numeric equivalent
+'	http://www.w3schools.com/charsets/ref_html_utf8.asp
+
+	Select Case psChar
+		Case """"			:	_UTF8Encode = """
+		Case "&"			:	_UTF8Encode = "&"
+		Case "<"			:	_UTF8Encode = "<"
+		Case ">"			:	_UTF8Encode = ">"
+		Case "'"			:	_UTF8Encode = "'"
+		Case ":", "/", "?", "#", "[", "]", "@"				'	Reserved characters
+			_UTF8Encode = psChar
+		Case Chr(13)		:	_UTF8Encode = ""			'	Carriage return
+		Case Chr(10)		:	_UTF8Encode = "<br>"		'	Line Feed
+		Case < Chr(126)		:	_UTF8Encode = psChar
+		Case "€"			:	_UTF8Encode = "€"
+		Case Else			:	_UTF8Encode = "&#" & Asc(psChar) & ";"
+	End Select
+
+	Exit Function
+
+End Function	'	_UTF8Encode V1.4.0
+
+
 </script:module>
\ No newline at end of file